Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Hs/Expr.hs
    ... ... @@ -1608,9 +1608,16 @@ is Less Cool because
    1608 1608 
     -}
    1609 1609
    1610 1610 
     data CmdTopTc
    1611 
    -  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack
    1612 
    -             Type    -- return type of the command
    1613 
    -             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
    1611 
    +  = CmdTopTc
    1612 
    +    -- | Nested tuple of inputs on the command's stack
    1613 
    +  { ctt_stack  :: Type
    1614 
    +    -- | Arrow type
    1615 
    +  , ctt_arr_ty :: Type
    1616 
    +    -- | Return type of the command
    1617 
    +  , ctt_res_ty :: Type
    1618 
    +    -- | Command syntax table; see Note [CmdSyntaxTable]
    1619 
    +  , ctt_table  :: CmdSyntaxTable GhcTc
    1620 
    +  }
    1614 1621
    1615 1622 
     type instance XCmdTop  GhcPs = NoExtField
    1616 1623 
     type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]

  • compiler/GHC/Hs/Syn/Type.hs
    ... ... @@ -25,6 +25,7 @@ import GHC.Tc.Types.Evidence
    25 25 
     import GHC.Types.Id
    26 26 
     import GHC.Types.Var( VarBndr(..) )
    27 27 
     import GHC.Types.SrcLoc
    28 
    +import GHC.Utils.Misc ( HasDebugCallStack )
    28 29 
     import GHC.Utils.Outputable
    29 30 
     import GHC.Utils.Panic
    30 31
    ... ... @@ -114,11 +115,16 @@ hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_gr
    114 115 
     hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
    115 116 
     hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x
    116 117 
     hsExprType (OpApp v _ _ _) = dataConCantHappen v
    117 
    -hsExprType (NegApp _ _ se) = syntaxExprType se
    118 
    +hsExprType (NegApp _ _ se) = syntaxExpr_wrappedFunResTy se
    118 119 
     hsExprType (HsPar _ e) = lhsExprType e
    119 120 
     hsExprType (SectionL v _ _) = dataConCantHappen v
    120 121 
     hsExprType (SectionR v _ _) = dataConCantHappen v
    121 
    -hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args
    122 
    +hsExprType (ExplicitTuple _ args box) =
    123 
    +  -- Deal with tuple sections: one function arrow per missing argument
    124 
    +  mkScaledFunTys [s | Missing s <- args] $
    125 
    +    -- Use 'mkTupleTy1' to avoid flattening 1-tuples, as per
    126 
    +    -- Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.
    127 
    +    mkTupleTy1 box (map hsTupArgType args)
    122 128 
     hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
    123 129 
     hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
    124 130 
     hsExprType (HsIf _ _ t _) = lhsExprType t
    ... ... @@ -126,25 +132,29 @@ hsExprType (HsMultiIf ty _) = ty
    126 132 
     hsExprType (HsLet _ _ body) = lhsExprType body
    127 133 
     hsExprType (HsDo ty _ _) = ty
    128 134 
     hsExprType (ExplicitList ty _) = mkListTy ty
    129 
    -hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
    135 
    +hsExprType (RecordCon con_expr _ _) = snd (splitFunTys (hsExprType con_expr))
    130 136 
     hsExprType (RecordUpd v _ _) = dataConCantHappen v
    131 137 
     hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v
    132 138 
     hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v
    133 139 
     hsExprType (ExprWithTySig _ e _) = lhsExprType e
    134 
    -hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
    135 
    -  Just op -> piResultTy (syntaxExprType op) asi_ty
    136 
    -  Nothing -> asi_ty
    137 
    -  where
    138 
    -    asi_ty = arithSeqInfoType asi
    140 
    +hsExprType (ArithSeq _ mb_overloaded_op asi) =
    141 
    +  case mb_overloaded_op of
    142 
    +    Just se -> syntaxExpr_wrappedFunResTy se
    143 
    +    Nothing -> arithSeqInfoType asi
    139 144 
     hsExprType (HsTypedBracket   (HsBracketTc { hsb_ty = ty }) _) = ty
    140 145 
     hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty
    141 
    -hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice"
    142 
    -                                          (ppr e)
    143 
    -                                      -- Typed splices should have been eliminated during zonking, but we
    144 
    -                                      -- can't use `dataConCantHappen` since they are still present before
    145 
    -                                      -- than in the typechecked AST.
    146 
    +hsExprType e@(HsTypedSplice{}) =
    147 
    +  -- Typed splices should have been eliminated during zonking, but we
    148 
    +  -- can't use `dataConCantHappen` since they are still present before
    149 
    +  -- then in the typechecked AST.
    150 
    +  pprPanic "hsExprType: Unexpected HsTypedSplice"
    151 
    +    (ppr e)
    146 152 
     hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext
    147 
    -hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
    153 
    +hsExprType (HsProc _ pat (L _ (HsCmdTop cmd_top_tc _))) =
    154 
    +  let CmdTopTc { ctt_arr_ty = arr_ty, ctt_res_ty = res_ty } = cmd_top_tc
    155 
    +  in
    156 
    +    -- (proc (pat :: a) -> (cmd :: b)) :: arr a b
    157 
    +    mkAppTys arr_ty [hsLPatType pat, res_ty]
    148 158 
     hsExprType (HsStatic (ty,_) _s) = ty
    149 159 
     hsExprType (HsPragE _ _ e) = lhsExprType e
    150 160 
     hsExprType (HsEmbTy x _) = dataConCantHappen x
    ... ... @@ -178,6 +188,13 @@ hsTupArgType :: HsTupArg GhcTc -> Type
    178 188 
     hsTupArgType (Present _ e)           = lhsExprType e
    179 189 
     hsTupArgType (Missing (Scaled _ ty)) = ty
    180 190
    191 
    +-- | The result type of a @SyntaxExpr GhcTc@ for a unary function,
    192 
    +-- including the result 'HsWrapper'.
    193 
    +syntaxExpr_wrappedFunResTy :: HasDebugCallStack => SyntaxExpr GhcTc -> Type
    194 
    +syntaxExpr_wrappedFunResTy (SyntaxExprTc { syn_expr = e, syn_res_wrap = wrap }) =
    195 
    +  hsWrapperType wrap (funResultTy (hsExprType e))
    196 
    +syntaxExpr_wrappedFunResTy NoSyntaxExprTc =
    197 
    +  panic "syntaxExpr_wrappedFunResTy: unexpected NoSyntaxExprTc"
    181 198
    182 199 
     -- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
    183 200 
     type PRType = (Type, [Type])
    ... ... @@ -191,7 +208,7 @@ liftPRType :: (Type -> Type) -> PRType -> PRType
    191 208 
     liftPRType f pty = (f (prTypeType pty), [])
    192 209
    193 210 
     hsWrapperType :: HsWrapper -> Type -> Type
    194 
    --- Return the type of (WrapExpr wrap e), given that e :: ty
    211 
    +-- ^ Return the type of @WrapExpr wrap e@, given that @e :: ty@
    195 212 
     hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
    196 213 
       where
    197 214 
         go WpHole              = id
    ... ... @@ -209,12 +226,5 @@ hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
    209 226 
         go (WpTyApp ta)       = \(ty,tas) -> (ty, ta:tas)
    210 227 
         go (WpLet _)          = id
    211 228
    212 
    -lhsCmdTopType :: LHsCmdTop GhcTc -> Type
    213 
    -lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
    214 
    -
    215 229 
     matchGroupTcType :: MatchGroupTc -> Type
    216 230 
     matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res
    217 
    -
    218 
    -syntaxExprType :: SyntaxExpr GhcTc -> Type
    219 
    -syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
    220 
    -syntaxExprType NoSyntaxExprTc       = panic "syntaxExprType: Unexpected NoSyntaxExprTc"

  • compiler/GHC/HsToCore/Arrows.hs
    ... ... @@ -284,7 +284,7 @@ dsProcExpr
    284 284 
             :: LPat GhcTc
    285 285 
             -> LHsCmdTop GhcTc
    286 286 
             -> DsM CoreExpr
    287 
    -dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
    287 
    +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc { ctt_res_ty = cmd_ty, ctt_table = ids }) cmd)) = do
    288 288 
         (meth_binds, meth_ids) <- mkCmdEnv ids
    289 289 
         let locals = mkVarSet (collectPatBinders CollWithDictBinders pat)
    290 290 
         (core_cmd, _free_vars, env_ids)
    ... ... @@ -656,8 +656,15 @@ dsTrimCmdArg
    656 656 
             -> DsM (CoreExpr,       -- desugared expression
    657 657 
                     DIdSet)         -- subset of local vars that occur free
    658 658 
     dsTrimCmdArg local_vars env_ids
    659 
    -                       (L _ (HsCmdTop
    660 
    -                                 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
    659 
    +  (L _
    660 
    +    (HsCmdTop
    661 
    +      (CmdTopTc
    662 
    +        { ctt_stack  = stack_ty
    663 
    +        , ctt_res_ty = cmd_ty
    664 
    +        , ctt_table  = ids
    665 
    +        })
    666 
    +      cmd)
    667 
    +  ) = do
    661 668 
         (meth_binds, meth_ids) <- mkCmdEnv ids
    662 669 
         (core_cmd, free_vars, env_ids')
    663 670 
            <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd

  • compiler/GHC/Tc/Gen/Arrow.hs
    ... ... @@ -136,7 +136,11 @@ tcCmdTop :: CmdEnv
    136 136 
     tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
    137 137 
       = setSrcSpanA loc $
    138 138 
         do  { cmd' <- tcCmd env cmd cmd_ty
    139 
    -        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }
    139 
    +        ; let cmd_top = CmdTopTc { ctt_stack  = cmd_stk
    140 
    +                                 , ctt_arr_ty = cmd_arr env
    141 
    +                                 , ctt_res_ty = res_ty
    142 
    +                                 , ctt_table  = names }
    143 
    +        ; return (L loc $ HsCmdTop cmd_top cmd') }
    140 144
    141 145 
     ----------------------------------------
    142 146 
     tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)

  • compiler/GHC/Tc/Zonk/Type.hs
    ... ... @@ -1211,10 +1211,14 @@ zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc)
    1211 1211 
     zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd
    1212 1212
    1213 1213 
     zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc)
    1214 
    -zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
    1214 
    +zonk_cmd_top (HsCmdTop (CmdTopTc { ctt_stack  = stack_tys
    1215 
    +                                 , ctt_arr_ty = arr_ty
    1216 
    +                                 , ctt_res_ty = res_ty
    1217 
    +                                 , ctt_table  = ids }) cmd)
    1215 1218 
       = do new_cmd <- zonkLCmd cmd
    1216 1219 
            new_stack_tys <- zonkTcTypeToTypeX stack_tys
    1217 
    -       new_ty <- zonkTcTypeToTypeX ty
    1220 
    +       new_arr_ty <- zonkTcTypeToTypeX arr_ty
    1221 
    +       new_res_ty <- zonkTcTypeToTypeX res_ty
    1218 1222 
            new_ids <- mapSndM zonkExpr ids
    1219 1223
    1220 1224 
            massert (definitelyLiftedType new_stack_tys)
    ... ... @@ -1222,7 +1226,13 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
    1222 1226 
              -- but indeed it should always be lifted due to the typing
    1223 1227 
              -- rules for arrows
    1224 1228
    1225 
    -       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
    1229 
    +       let new_cmd_top =
    1230 
    +             CmdTopTc { ctt_stack  = new_stack_tys
    1231 
    +                      , ctt_arr_ty = new_arr_ty
    1232 
    +                      , ctt_res_ty = new_res_ty
    1233 
    +                      , ctt_table  = new_ids }
    1234 
    +
    1235 
    +       return (HsCmdTop new_cmd_top new_cmd)
    1226 1236
    1227 1237 
     -------------------------------------------------------------------------
    1228 1238 
     zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper

  • testsuite/tests/ghc-api/T26910.hs
    1 
    +module Main where
    2 
    +
    3 
    +-- base
    4 
    +import Control.Applicative
    5 
    +import Control.Monad.IO.Class
    6 
    +  ( liftIO )
    7 
    +import Data.List.NonEmpty
    8 
    +  ( NonEmpty (..) )
    9 
    +import System.Environment
    10 
    +  ( getArgs )
    11 
    +
    12 
    +-- directory
    13 
    +import System.Directory
    14 
    +  ( removeFile )
    15 
    +
    16 
    +-- ghc
    17 
    +import GHC
    18 
    +import GHC.Data.Bag
    19 
    +  ( bagToList )
    20 
    +import GHC.Driver.Ppr
    21 
    +  ( showSDoc )
    22 
    +import GHC.Driver.Session
    23 
    +import GHC.Hs
    24 
    +import GHC.Hs.Syn.Type
    25 
    +  ( hsExprType )
    26 
    +import GHC.Types.Name
    27 
    +  ( nameOccName, occNameString )
    28 
    +import GHC.Types.Var
    29 
    +  ( varName )
    30 
    +import GHC.Unit.Types
    31 
    +  ( GenUnit (..), Definite (..) )
    32 
    +import GHC.Utils.Outputable
    33 
    +  ( ppr )
    34 
    +
    35 
    +--------------------------------------------------------------------------------
    36 
    +
    37 
    +findBindBody :: String -> LHsBinds GhcTc -> Maybe (HsExpr GhcTc)
    38 
    +findBindBody name = asum . map go
    39 
    +  where
    40 
    +    go (L _ FunBind { fun_id = L _ fid
    41 
    +                    , fun_matches = MG { mg_alts = L _ (m:_) } })
    42 
    +      | occNameString (nameOccName (varName fid)) == name
    43 
    +      = case m_grhss (unLoc m) of
    44 
    +          GRHSs { grhssGRHSs = L _ (GRHS _ _ bodyL) :| _ } -> Just (unLoc bodyL)
    45 
    +    go (L _ (XHsBindsLR AbsBinds { abs_binds })) = findBindBody name abs_binds
    46 
    +    go _                                         = Nothing
    47 
    +
    48 
    +checkBinding :: DynFlags -> String -> LHsBinds GhcTc -> IO ()
    49 
    +checkBinding dflags name tcSrc =
    50 
    +  case findBindBody name tcSrc of
    51 
    +    Nothing   ->
    52 
    +      putStrLn $ name ++ " NOT FOUND"
    53 
    +    Just body ->
    54 
    +      putStrLn $
    55 
    +        "(<body of " ++ name ++ ">) :: " ++ showSDoc dflags (ppr (hsExprType body))
    56 
    +
    57 
    +main :: IO ()
    58 
    +main = do
    59 
    +  [libdir] <- getArgs
    60 
    +  runGhc (Just libdir) $ do
    61 
    +    dflags <- getSessionDynFlags
    62 
    +    logger <- getLogger
    63 
    +
    64 
    +    -- Add 'template-haskell' dependency
    65 
    +    (dflags, _, _) <- parseDynamicFlags logger dflags [noLoc "-package template-haskell"]
    66 
    +    setSessionDynFlags dflags
    67 
    +
    68 
    +    let modName = mkModuleName "T26910_Input"
    69 
    +        m = mkModule (RealUnit (Definite (homeUnitId_ dflags))) modName
    70 
    +    addTarget Target
    71 
    +      { targetId           = TargetModule modName
    72 
    +      , targetAllowObjCode = True
    73 
    +      , targetUnitId       = homeUnitId_ dflags
    74 
    +      , targetContents     = Nothing
    75 
    +      }
    76 
    +    _ <- load LoadAllTargets
    77 
    +    modSum <- getModSummary m
    78 
    +    parsed <- parseModule modSum
    79 
    +    tc     <- typecheckModule parsed
    80 
    +
    81 
    +    let tcSrc = tm_typechecked_source tc
    82 
    +        check name = liftIO $ checkBinding dflags name tcSrc
    83 
    +
    84 
    +    check "e_reccon"    -- RecordCon
    85 
    +    check "e_negapp"    -- NegApp
    86 
    +    check "e_proc"      -- HsProc
    87 
    +    check "e_arith_ol"  -- ArithSeq
    88 
    +
    89 
    +    check "e_var"       -- ConLikeTc
    90 
    +    check "e_lit"       -- HsLit
    91 
    +    check "e_overlit"   -- HsOverLit
    92 
    +    check "e_lam"       -- HsLam
    93 
    +    check "e_app"       -- HsApp
    94 
    +    check "e_apptype"   -- HsAppType
    95 
    +    check "e_par"       -- HsPar
    96 
    +    check "e_tuple1"    -- ExplicitTuple
    97 
    +    check "e_tuple2"    -- ExplicitTuple + TupleSections
    98 
    +    check "e_tuple3"    -- ExplicitTuple 1-tuple (with Template Haskell)
    99 
    +    check "e_utuple1"   -- ExplicitTuple (unboxed)
    100 
    +    check "e_utuple2"   -- ExplicitTuple + TupleSections (unboxed)
    101 
    +    check "e_usum"      -- Unboxed sums
    102 
    +    check "e_case"      -- HsCase
    103 
    +    check "e_if"        -- HsIf
    104 
    +    check "e_multiif"   -- HsMultiIf
    105 
    +    check "e_let"       -- HsLet
    106 
    +    check "e_list"      -- ExplicitList + OverloadedLists
    107 
    +    check "e_arith"     -- ArithSeq
    108 
    +    check "e_tysig"     -- ExprWithTySig
    109 
    +    check "e_listcomp"  -- HsDo (ListComp)
    110 
    +    check "e_recsel"    -- HsRecSelTc
    111 
    +    check "e_ubracket"  -- HsUntypedBracket
    112 
    +    check "e_tbracket"  -- HsTypedBracket
    113 
    +    check "e_static"    -- HsStatic

  • testsuite/tests/ghc-api/T26910.stdout
    1 
    +(<body of e_reccon>) :: MyRec
    2 
    +(<body of e_negapp>) :: T Word
    3 
    +(<body of e_proc>) :: Int -> Int
    4 
    +(<body of e_arith_ol>) :: MyList Int
    5 
    +(<body of e_var>) :: Either Int Bool
    6 
    +(<body of e_lit>) :: Char
    7 
    +(<body of e_overlit>) :: T Word
    8 
    +(<body of e_lam>) :: Bool -> Bool
    9 
    +(<body of e_app>) :: Bool
    10 
    +(<body of e_apptype>) :: Bool -> Bool
    11 
    +(<body of e_par>) :: Bool
    12 
    +(<body of e_tuple1>) :: (Int, Bool)
    13 
    +(<body of e_tuple2>) :: Int -> (Int, Bool)
    14 
    +(<body of e_tuple3>) :: Solo Char
    15 
    +(<body of e_utuple1>) :: (# Int, Int# #)
    16 
    +(<body of e_utuple2>) :: Int -> Int# -> (# Int, Int# #)
    17 
    +(<body of e_usum>) :: (# Int# | Word# #)
    18 
    +(<body of e_case>) :: Bool
    19 
    +(<body of e_if>) :: Char
    20 
    +(<body of e_multiif>) :: Int
    21 
    +(<body of e_let>) :: Int
    22 
    +(<body of e_list>) :: [Int]
    23 
    +(<body of e_arith>) :: MyList Int
    24 
    +(<body of e_tysig>) :: Bool
    25 
    +(<body of e_listcomp>) :: [Int]
    26 
    +(<body of e_recsel>) :: MyRec -> Int
    27 
    +(<body of e_ubracket>) :: Q Exp
    28 
    +(<body of e_tbracket>) :: Code Q Char
    29 
    +(<body of e_static>) :: StaticPtr Bool

  • testsuite/tests/ghc-api/T26910_Input.hs
    1 
    +{-# LANGUAGE Arrows #-}
    2 
    +{-# LANGUAGE DataKinds #-}
    3 
    +{-# LANGUAGE MagicHash #-}
    4 
    +{-# LANGUAGE MultiWayIf #-}
    5 
    +{-# LANGUAGE OverloadedLists #-}
    6 
    +{-# LANGUAGE RebindableSyntax #-}
    7 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    8 
    +{-# LANGUAGE StaticPointers #-}
    9 
    +{-# LANGUAGE TemplateHaskell #-}
    10 
    +{-# LANGUAGE TupleSections #-}
    11 
    +{-# LANGUAGE TypeApplications #-}
    12 
    +{-# LANGUAGE TypeFamilies #-}
    13 
    +{-# LANGUAGE UnboxedSums #-}
    14 
    +{-# LANGUAGE UnboxedTuples #-}
    15 
    +
    16 
    +module T26910_Input where
    17 
    +
    18 
    +-- base
    19 
    +import Prelude
    20 
    +  hiding ( negate, fromInteger )
    21 
    +import qualified Prelude
    22 
    +import Control.Arrow
    23 
    +  ( (>>>), arr, first, returnA )
    24 
    +import Data.Kind
    25 
    +  ( Type )
    26 
    +import Data.Tuple
    27 
    +  ( Solo(..) )
    28 
    +import GHC.Exts
    29 
    +  ( TYPE, RuntimeRep(..), LiftedRep
    30 
    +  , IsList (..)
    31 
    +  , Int#, Word#
    32 
    +  )
    33 
    +import GHC.StaticPtr
    34 
    +  ( StaticPtr )
    35 
    +
    36 
    +-- template-haskell
    37 
    +import qualified Language.Haskell.TH as TH
    38 
    +
    39 
    +--------------------------------------------------------------------------------
    40 
    +
    41 
    +ifThenElse :: Bool -> a -> a -> a
    42 
    +ifThenElse c t f =
    43 
    +  case c of
    44 
    +    True  -> t
    45 
    +    False -> f
    46 
    +
    47 
    +data MyRec = MyRec { recInt :: Int, recBool :: Bool }
    48 
    +
    49 
    +-- Used to test ArithSeq with overloaded fromList (OverloadedLists)
    50 
    +newtype MyList a = MyList [a]
    51 
    +instance IsList (MyList a) where
    52 
    +  type Item (MyList a) = a
    53 
    +  fromList = MyList
    54 
    +  toList (MyList xs) = xs
    55 
    +
    56 
    +-- RecordCon
    57 
    +e_reccon :: MyRec
    58 
    +e_reccon = MyRec { recInt = 1, recBool = True }
    59 
    +
    60 
    +-- NegApp
    61 
    +e_negapp :: T Word
    62 
    +e_negapp = -(1 :: Int)
    63 
    +
    64 
    +type R :: Type -> RuntimeRep
    65 
    +type family R a where
    66 
    +  R Word = LiftedRep
    67 
    +
    68 
    +type T :: forall (a :: Type) -> TYPE (R a)
    69 
    +type family T a where
    70 
    +  T Word = Int
    71 
    +
    72 
    +-- Weird RebindableSyntax negation that involves casts
    73 
    +negate :: T Word -> T Word
    74 
    +negate = Prelude.negate
    75 
    +
    76 
    +-- HsProc
    77 
    +e_proc :: Int -> Int
    78 
    +e_proc = proc x -> returnA -< x
    79 
    +
    80 
    +-- ArithSeq (with OverloadedLists)
    81 
    +e_arith_ol :: MyList Int
    82 
    +e_arith_ol = [1..10 :: Int]
    83 
    +
    84 
    +-- XExpr (ConLikeTc)
    85 
    +e_var :: Either Int Bool
    86 
    +e_var = Left 3
    87 
    +
    88 
    +-- HsLit
    89 
    +e_lit :: Char
    90 
    +e_lit = 'x'
    91 
    +
    92 
    +-- HsOverLit
    93 
    +e_overlit :: T Word
    94 
    +e_overlit = 42
    95 
    +
    96 
    +fromInteger :: Integer -> T Word
    97 
    +fromInteger = Prelude.fromInteger
    98 
    +
    99 
    +-- HsLam
    100 
    +e_lam :: Bool -> Bool
    101 
    +e_lam = \ x -> not x
    102 
    +
    103 
    +-- HsApp
    104 
    +e_app :: Bool
    105 
    +e_app = not True
    106 
    +
    107 
    +-- HsAppType
    108 
    +e_apptype :: Bool -> Bool
    109 
    +e_apptype = id @Bool
    110 
    +
    111 
    +-- HsPar
    112 
    +e_par :: Bool
    113 
    +e_par = (True)
    114 
    +
    115 
    +-- ExplicitTuple
    116 
    +e_tuple1 :: (Int, Bool)
    117 
    +e_tuple1 = (1 :: Int, True)
    118 
    +
    119 
    +-- ExplicitTuple + TupleSections
    120 
    +e_tuple2 :: Int -> (Int, Bool)
    121 
    +e_tuple2 = (, True)
    122 
    +
    123 
    +-- ExplicitTuple one-tuple
    124 
    +e_tuple3 :: Solo Char
    125 
    +e_tuple3 =
    126 
    +  $( return $ TH.TupE [ Just $ TH.LitE ( TH.CharL 'x' ) ] )
    127 
    +
    128 
    +-- Unboxed tuple
    129 
    +e_utuple1 :: () -> (# Int, Int# #)
    130 
    +e_utuple1 _ = (# 1, 1# #)
    131 
    +
    132 
    +-- Unboxed tuple + TupleSections
    133 
    +e_utuple2 :: Int -> Int# -> (# Int, Int# #)
    134 
    +e_utuple2 = (# , #)
    135 
    +
    136 
    +-- Unboxed sums
    137 
    +e_usum :: () -> (# Int# | Word# #)
    138 
    +e_usum _ = (# 1# | #)
    139 
    +
    140 
    +-- HsCase
    141 
    +e_case :: Bool
    142 
    +e_case = case id True of { True -> False; False -> True }
    143 
    +
    144 
    +-- HsIf
    145 
    +e_if :: Char
    146 
    +e_if = if id True then 'x' else 'y'
    147 
    +
    148 
    +-- HsMultiIf
    149 
    +e_multiif :: Int
    150 
    +e_multiif = if | id True   -> (1 :: Int)
    151 
    +               | otherwise -> (2 :: Int)
    152 
    +
    153 
    +-- HsLet
    154 
    +e_let :: Int
    155 
    +e_let = let x = 1 :: Int in x
    156 
    +
    157 
    +-- ExplicitList
    158 
    +e_list :: [Int]
    159 
    +e_list = [1 :: Int, 2, 3]
    160 
    +
    161 
    +-- ArithSeq with overloaded fromList
    162 
    +e_arith :: MyList Int
    163 
    +e_arith = [1 :: Int ..]
    164 
    +
    165 
    +-- ExprWithTySig
    166 
    +e_tysig :: Bool
    167 
    +e_tysig = (True :: Bool)
    168 
    +
    169 
    +-- HsDo ListComp
    170 
    +e_listcomp :: [Int]
    171 
    +e_listcomp = [x | x <- [1 :: Int, 2, 3]]
    172 
    +
    173 
    +-- HsRecSelTc
    174 
    +e_recsel :: MyRec -> Int
    175 
    +e_recsel = recInt
    176 
    +
    177 
    +-- HsUntypedBracket
    178 
    +e_ubracket :: TH.Q TH.Exp
    179 
    +e_ubracket = [| 'y' |]
    180 
    +
    181 
    +-- HsTypedBracket
    182 
    +e_tbracket :: TH.Code TH.Q Char
    183 
    +e_tbracket = [|| 'z' ||]
    184 
    +
    185 
    +-- HsStatic
    186 
    +e_static :: StaticPtr Bool
    187 
    +e_static = static True

  • testsuite/tests/ghc-api/all.T
    ... ... @@ -74,4 +74,8 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"')
    74 74 
     test('T26120', [], compile_and_run, ['-package ghc'])
    75 75
    76 76 
     test('T26264', normal, compile_and_run, ['-package ghc'])
    77 
    +test('T26910', [ extra_run_opts(f'"{config.libdir}"')
    78 
    +               # doesn't work in wasm/js due to lack of pipe(2) support
    79 
    +               , when(arch('wasm32') or arch('javascript'), skip)
    80 
    +               ], compile_and_run, ['-package ghc -package template-haskell'])
    77 81 
     test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help