toHsType
)
-import PrelNames ( mETA_META_Name, rationalTyConName )
+import PrelNames ( mETA_META_Name, rationalTyConName, negateName,
+ parrTyConName )
import MkIface ( ifaceTyThing )
-import Name ( Name, nameOccName, nameModule )
+import Name ( Name, nameOccName, nameModule, getSrcLoc )
import OccName ( isDataOcc, isTvOcc, occNameUserString )
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
import OccName ( mkOccFS )
import NameEnv
import NameSet
-import Type ( Type, TyThing(..), mkGenTyConApp )
+import Type ( Type, mkGenTyConApp )
+import TcType ( TyThing(..), tcTyConAppArgs )
import TyCon ( DataConDetails(..) )
import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils ( exprType )
import SrcLoc ( noSrcLoc )
-import Maybe ( catMaybes )
+import Maybes ( orElse )
+import Maybe ( catMaybes, fromMaybe )
import Panic ( panic )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
+import SrcLoc ( SrcLoc )
import Outputable
import FastString ( mkFastString )
+
+import Monad ( zipWithM )
+import List ( sortBy )
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
--- Returns a CoreExpr of type M.Expr
+-- Returns a CoreExpr of type M.ExpQ
-- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations!
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
--- Returns a CoreExpr of type reifyType --> M.Type
--- reifyDecl --> M.Decl
+-- Returns a CoreExpr of type reifyType --> M.TypQ
+-- reifyDecl --> M.DecQ
-- reifyFixty --> Q M.Fix
dsReify (ReifyOut ReifyType name)
= do { thing <- dsLookupGlobal name ;
-- Declarations
-------------------------------------------------------
-repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
+repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
repTopDs group
= do { let { bndrs = groupBinders group } ;
ss <- mkGenSyms bndrs ;
-- do { t :: String <- genSym "T" ;
-- return (Data t [] ...more t's... }
-- The other important reason is that the output must mention
- -- only "T", not "Foo.T" where Foo is the current module
+ -- only "T", not "Foo:T" where Foo is the current module
decls <- addBinds ss (do {
- val_ds <- rep_binds (hs_valds group) ;
- tycl_ds <- mapM repTyClD (hs_tyclds group) ;
- inst_ds <- mapM repInstD (hs_instds group) ;
+ val_ds <- rep_binds' (hs_valds group) ;
+ tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
+ inst_ds <- mapM repInstD' (hs_instds group) ;
-- more needed
- return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
+ return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
+
+ decl_ty <- lookupType declTyConName ;
+ let { core_list = coreList' decl_ty decls } ;
- core_list <- coreList declTyConName decls ;
- wrapNongenSyms ss core_list
+ dec_ty <- lookupType decTyConName ;
+ q_decs <- repSequenceQ dec_ty core_list ;
+
+ wrapNongenSyms ss q_decs
-- Do *not* gensym top-level binders
}
-}
-repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
+repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
+repTyClD decl = do x <- repTyClD' decl
+ return (fmap snd x)
+
+repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))
-repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
+repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
tcdName = tc, tcdTyVars = tvs,
- tcdCons = DataCons cons, tcdDerivs = mb_derivs })
- = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
- tvs1 <- repTvs tvs ;
- cons1 <- mapM repC cons ;
- cons2 <- coreList consTyConName cons1 ;
- derivs1 <- repDerivs mb_derivs ;
- dec <- repData tc1 tvs1 cons2 derivs1 ;
- return (Just dec) }
-
-repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
- tcdTyVars = tvs, tcdFDs = [],
- tcdSigs = sigs, tcdMeths = Just binds
- })
+ tcdCons = DataCons cons, tcdDerivs = mb_derivs,
+ tcdLoc = loc})
+ = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repContext cxt ;
+ cons1 <- mapM repC cons ;
+ cons2 <- coreList consTyConName cons1 ;
+ derivs1 <- repDerivs mb_derivs ;
+ repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
+ return $ Just (loc, dec) }
+
+repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt,
+ tcdName = tc, tcdTyVars = tvs,
+ tcdCons = DataCons [con], tcdDerivs = mb_derivs,
+ tcdLoc = loc})
+ = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repContext cxt ;
+ con1 <- repC con ;
+ derivs1 <- repDerivs mb_derivs ;
+ repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
+ return $ Just (loc, dec) }
+
+repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
+ tcdLoc = loc})
+ = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ ty1 <- repTy ty ;
+ repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
+ return (Just (loc, dec)) }
+
+repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls,
+ tcdTyVars = tvs,
+ tcdFDs = [], -- We don't understand functional dependencies
+ tcdSigs = sigs, tcdMeths = mb_meth_binds,
+ tcdLoc = loc})
= do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
- tvs1 <- repTvs tvs ;
- cxt1 <- repCtxt cxt ;
- sigs1 <- rep_sigs sigs ;
- binds1 <- rep_monobind binds ;
- decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
- dec <- repClass cxt1 cls1 tvs1 decls1 ;
- return (Just dec) }
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repContext cxt ;
+ sigs1 <- rep_sigs sigs ;
+ binds1 <- rep_monobind meth_binds ;
+ decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
+ repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
+ return $ Just (loc, dec) }
+ where
+ -- If the user quotes a class decl, it'll have default-method
+ -- bindings; but if we (reifyDecl C) where C is a class, we
+ -- won't be given the default methods (a definite infelicity).
+ meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
-- Un-handled cases
-repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
+repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
return Nothing
}
where
msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
-repInstD (InstDecl ty binds _ _ loc)
+repInstD' (InstDecl ty binds _ _ loc)
-- Ignore user pragmas for now
- = do { cxt1 <- repCtxt cxt ;
+ = do { cxt1 <- repContext cxt ;
inst_ty1 <- repPred (HsClassP cls tys) ;
binds1 <- rep_monobind binds ;
decls1 <- coreList declTyConName binds1 ;
- repInst cxt1 inst_ty1 decls1 }
+ i <- repInst cxt1 inst_ty1 decls1;
+ return (loc, i)}
where
(tvs, cxt, cls, tys) = splitHsInstDeclTy ty
-- Constructors
-------------------------------------------------------
-repC :: ConDecl Name -> DsM (Core M.Cons)
+repC :: ConDecl Name -> DsM (Core M.ConQ)
repC (ConDecl con [] [] details loc)
= do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
- arg_tys <- mapM (repBangTy con) (hsConArgs details) ;
- arg_tys1 <- coreList typeTyConName arg_tys ;
- repConstr con1 arg_tys1 }
+ repConstr con1 details }
-repBangTy con (BangType NotMarkedStrict ty) = repTy ty
-repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
- where
- msg = ptext SLIT("Ignoring stricness on argument of constructor")
- <+> quotes (ppr con)
+repBangTy :: BangType Name -> DsM (Core (M.StrictTypQ))
+repBangTy (BangType str ty) = do MkC s <- rep2 strName []
+ MkC t <- repTy ty
+ rep2 strictTypeName [s, t]
+ where strName = case str of
+ NotMarkedStrict -> nonstrictName
+ _ -> strictName
-------------------------------------------------------
-- Deriving clause
-- Signatures in a class decl, or a group of bindings
-------------------------------------------------------
-rep_sigs :: [Sig Name] -> DsM [Core M.Decl]
+rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
+rep_sigs sigs = do locs_cores <- rep_sigs' sigs
+ return $ de_loc $ sort_by_loc locs_cores
+
+rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
-- We silently ignore ones we don't recognise
-rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ;
+rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
return (concat sigs1) }
-rep_sig :: Sig Name -> DsM [Core M.Decl]
+rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
-rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
-rep_sig (Sig nm ty _) = rep_proto nm ty
+rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc
+rep_sig (Sig nm ty loc) = rep_proto nm ty loc
rep_sig other = return []
-rep_proto nm ty = do { nm1 <- lookupBinder nm ;
+rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
+rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
ty1 <- repTy ty ;
sig <- repProto nm1 ty1 ;
- return [sig] }
+ return [(loc, sig)] }
-------------------------------------------------------
-- Types
-------------------------------------------------------
-repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
-repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
- return (coreList' stringTy tvs1) }
-
------------------
-repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
-repCtxt ctxt = do { preds <- mapM repPred ctxt;
- coreList typeTyConName preds }
-
------------------
-repPred :: HsPred Name -> DsM (Core M.Type)
-repPred (HsClassP cls tys)
- = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1;
- tys1 <- repTys tys; repTapps tcon tys1 }
-repPred (HsIParam _ _) = panic "No implicit parameters yet"
+-- gensym a list of type variables and enter them into the meta environment;
+-- the computations passed as the second argument is executed in that extended
+-- meta environment and gets the *new* names on Core-level as an argument
+--
+addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
+ -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
+ -> DsM (Core (M.Q a))
+addTyVarBinds tvs m =
+ do
+ let names = map hsTyVarName tvs
+ freshNames <- mkGenSyms names
+ term <- addBinds freshNames $ do
+ bndrs <- mapM lookupBinder names
+ m bndrs
+ wrapGenSyns freshNames term
+
+-- represent a type context
+--
+repContext :: HsContext Name -> DsM (Core M.CxtQ)
+repContext ctxt = do
+ preds <- mapM repPred ctxt
+ predList <- coreList typeTyConName preds
+ repCtxt predList
------------------
-repTys :: [HsType Name] -> DsM [Core M.Type]
+-- represent a type predicate
+--
+repPred :: HsPred Name -> DsM (Core M.TypQ)
+repPred (HsClassP cls tys) = do
+ tcon <- repTy (HsTyVar cls)
+ tys1 <- repTys tys
+ repTapps tcon tys1
+repPred (HsIParam _ _) =
+ panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
+
+-- yield the representation of a list of types
+--
+repTys :: [HsType Name] -> DsM [Core M.TypQ]
repTys tys = mapM repTy tys
------------------
-repTy :: HsType Name -> DsM (Core M.Type)
+-- represent a type
+--
+repTy :: HsType Name -> DsM (Core M.TypQ)
+repTy (HsForAllTy bndrs ctxt ty) =
+ addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
+ ctxt' <- repContext ctxt
+ ty' <- repTy ty
+ repTForall (coreList' stringTy bndrs') ctxt' ty'
repTy (HsTyVar n)
- | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 }
- | otherwise = do { tc1 <- lookupOcc n; repNamedTyCon tc1 }
-repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 }
-repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ;
- tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
-repTy (HsListTy t) = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 }
-repTy (HsTupleTy tc tys) = do { tys1 <- repTys tys;
- tcon <- repTupleTyCon (length tys);
- repTapps tcon tys1 }
+ | isTvOcc (nameOccName n) = do
+ tv1 <- lookupBinder n
+ repTvar tv1
+ | otherwise = do
+ tc1 <- lookupOcc n
+ repNamedTyCon tc1
+repTy (HsAppTy f a) = do
+ f1 <- repTy f
+ a1 <- repTy a
+ repTapp f1 a1
+repTy (HsFunTy f a) = do
+ f1 <- repTy f
+ a1 <- repTy a
+ tcon <- repArrowTyCon
+ repTapps tcon [f1, a1]
+repTy (HsListTy t) = do
+ t1 <- repTy t
+ tcon <- repListTyCon
+ repTapp tcon t1
+repTy (HsPArrTy t) = do
+ t1 <- repTy t
+ tcon <- repTy (HsTyVar parrTyConName)
+ repTapp tcon t1
+repTy (HsTupleTy tc tys) = do
+ tys1 <- repTys tys
+ tcon <- repTupleTyCon (length tys)
+ repTapps tcon tys1
repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
-repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
+repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1)
+ `HsAppTy` ty2)
repTy (HsParTy t) = repTy t
-repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
+repTy (HsNumTy i) =
+ panic "DsMeta.repTy: Can't represent number types (for generics)"
+repTy (HsPredTy pred) = repPred pred
+repTy (HsKindSig ty kind) =
+ panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
-repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig
-----------------------------------------------------------------------------
-- Expressions
-----------------------------------------------------------------------------
-repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
+repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
repEs es = do { es' <- mapM repE es ;
coreList exprTyConName es' }
-- FIXME: some of these panics should be converted into proper error messages
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
-repE :: HsExpr Name -> DsM (Core M.Expr)
+repE :: HsExpr Name -> DsM (Core M.ExpQ)
repE (HsVar x) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
repE (OpApp e1 op fix e2) =
- case op of
- HsVar op -> do { arg1 <- repE e1;
- arg2 <- repE e2;
- the_op <- lookupOcc op ;
- repInfixApp arg1 the_op arg2 }
- _ -> panic "DsMeta.repE: Operator is not a variable"
-repE (NegApp x nm) = repE x >>= repNeg
+ do { arg1 <- repE e1;
+ arg2 <- repE e2;
+ the_op <- repE op ;
+ repInfixApp arg1 the_op arg2 }
+repE (NegApp x nm) = do
+ a <- repE x
+ negateVar <- lookupOcc negateName >>= repVar
+ negateVar `repApp` a
repE (HsPar x) = repE x
repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repE e)
; z <- repLetE ds e2
- ; wrapGenSyns expTyConName ss z }
+ ; wrapGenSyns ss z }
-- FIXME: I haven't got the types here right yet
-repE (HsDo ctxt sts _ ty loc)
- | isComprCtxt ctxt = do { (ss,zs) <- repSts sts;
- e <- repDoE (nonEmptyCoreList zs);
- wrapGenSyns expTyConName ss e }
- | otherwise =
- panic "DsMeta.repE: Can't represent mdo and [: :] yet"
- where
- isComprCtxt ListComp = True
- isComprCtxt DoExpr = True
- isComprCtxt _ = False
+repE (HsDo DoExpr sts _ ty loc)
+ = do { (ss,zs) <- repSts sts;
+ e <- repDoE (nonEmptyCoreList zs);
+ wrapGenSyns ss e }
+repE (HsDo ListComp sts _ ty loc)
+ = do { (ss,zs) <- repSts sts;
+ e <- repComp (nonEmptyCoreList zs);
+ wrapGenSyns ss e }
+repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
repE (ExplicitPArr ty es) =
panic "DsMeta.repE: No explicit parallel arrays yet"
repE (ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repEs es; repTup xs }
| otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
-repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
-repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
+repE (RecordCon c flds)
+ = do { x <- lookupOcc c;
+ fs <- repFields flds;
+ repRecCon x fs }
+repE (RecordUpd e flds)
+ = do { x <- repE e;
+ fs <- repFields flds;
+ repRecUpd x fs }
repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
-repE (ArithSeqOut _ aseq) =
+repE (ArithSeqIn aseq) =
case aseq of
From e -> do { ds1 <- repE e; repFrom ds1 }
FromThen e1 e2 -> do
ds3 <- repE e3
repFromThenTo ds1 ds2 ds3
repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _) =
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
-repMatchTup :: Match Name -> DsM (Core M.Mtch)
+repMatchTup :: Match Name -> DsM (Core M.MatchQ)
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; addBinds ss2 $ do {
; gs <- repGuards guards
; match <- repMatch p1 gs ds
- ; wrapGenSyns matTyConName (ss1++ss2) match }}}
+ ; wrapGenSyns (ss1++ss2) match }}}
-repClauseTup :: Match Name -> DsM (Core M.Clse)
+repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
; addBinds ss2 $ do {
gs <- repGuards guards
; clause <- repClause ps1 gs ds
- ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
+ ; wrapGenSyns (ss1++ss2) clause }}}
-repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
+repGuards :: [GRHS Name] -> DsM (Core M.RHSQ)
repGuards [GRHS [ResultStmt e loc] loc2]
= do {a <- repE e; repNormal a }
repGuards other
= do { x <- repE e1; y <- repE e2; return (x, y) }
process other = panic "Non Haskell 98 guarded body"
+repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
+repFields flds = do
+ fnames <- mapM lookupOcc (map fst flds)
+ es <- mapM repE (map snd flds)
+ fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
+ coreList fieldTyConName fs
+
-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.
-repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
+repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
repSts [ResultStmt e loc] =
do { a <- repE e
; e1 <- repNoBindSt a
-- Bindings
-----------------------------------------------------------
-repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
+repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
repBinds decs
= do { let { bndrs = collectHsBinders decs } ;
ss <- mkGenSyms bndrs ;
core_list <- coreList declTyConName core ;
return (ss, core_list) }
-rep_binds :: HsBinds Name -> DsM [Core M.Decl]
-rep_binds EmptyBinds = return []
-rep_binds (ThenBinds x y)
- = do { core1 <- rep_binds x
- ; core2 <- rep_binds y
+rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
+rep_binds binds = do locs_cores <- rep_binds' binds
+ return $ de_loc $ sort_by_loc locs_cores
+
+rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
+rep_binds' EmptyBinds = return []
+rep_binds' (ThenBinds x y)
+ = do { core1 <- rep_binds' x
+ ; core2 <- rep_binds' y
; return (core1 ++ core2) }
-rep_binds (MonoBind bs sigs _)
- = do { core1 <- rep_monobind bs
- ; core2 <- rep_sigs sigs
+rep_binds' (MonoBind bs sigs _)
+ = do { core1 <- rep_monobind' bs
+ ; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
-rep_binds (IPBinds _ _)
+rep_binds' (IPBinds _ _)
= panic "DsMeta:repBinds: can't do implicit parameters"
-rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
-rep_monobind EmptyMonoBinds = return []
-rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
- y1 <- rep_monobind y;
+rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
+rep_monobind binds = do locs_cores <- rep_monobind' binds
+ return $ de_loc $ sort_by_loc locs_cores
+
+rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
+rep_monobind' EmptyMonoBinds = return []
+rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
+ y1 <- rep_monobind' y;
return (x1 ++ y1) }
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
+rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupBinder fn
; p <- repPvar fn'
; ans <- repVal p guardcore wherecore
- ; return [ans] }
+ ; return [(loc, ans)] }
-rep_monobind (FunMonoBind fn infx ms loc)
+rep_monobind' (FunMonoBind fn infx ms loc)
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
- ; return [ans] }
+ ; return [(loc, ans)] }
-rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
+rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
= do { patcore <- repP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans <- repVal patcore guardcore wherecore
- ; return [ans] }
+ ; return [(loc, ans)] }
-rep_monobind (VarMonoBind v e)
+rep_monobind' (VarMonoBind v e)
= do { v' <- lookupBinder v
; e2 <- repE e
; x <- repNormal e2
; patcore <- repPvar v'
; empty_decls <- coreList declTyConName []
; ans <- repVal patcore x empty_decls
- ; return [ans] }
+ ; return [(getSrcLoc v, ans)] }
-----------------------------------------------------------------------------
-- Since everything in a MonoBind is mutually recursive we need rename all
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.
-repLambda :: Match Name -> DsM (Core M.Expr)
+repLambda :: Match Name -> DsM (Core M.ExpQ)
repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
EmptyBinds _))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repPs ps; body <- repE e; repLam xs body })
- ; wrapGenSyns expTyConName ss lam }
+ ; wrapGenSyns ss lam }
repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
-- variable should already appear in the environment.
-- Process a list of patterns
-repPs :: [Pat Name] -> DsM (Core [M.Patt])
+repPs :: [Pat Name] -> DsM (Core [M.Pat])
repPs ps = do { ps' <- mapM repP ps ;
coreList pattTyConName ps' }
-repP :: Pat Name -> DsM (Core M.Patt)
+repP :: Pat Name -> DsM (Core M.Pat)
repP (WildPat _) = repPwild
repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
= do { con_str <- lookupOcc dc
; case details of
PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
- RecCon pairs -> error "No records in template haskell yet"
+ RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
+ ; ps <- sequence $ map repP (map snd pairs)
+ ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
+ ; fps' <- coreList fieldPTyConName fps
+ ; repPrec con_str fps' }
InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
}
+repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
+repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
repP other = panic "Exotic pattern inside meta brackets"
-repListPat :: [Pat Name] -> DsM (Core M.Patt)
+repListPat :: [Pat Name] -> DsM (Core M.Pat)
repListPat [] = do { nil_con <- coreStringLit "[]"
; nil_args <- coreList pattTyConName []
; repPcon nil_con nil_args }
----------------------------------------------------------
+-- Declaration ordering helpers
+
+sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
+sort_by_loc xs = sortBy comp xs
+ where comp x y = compare (fst x) (fst y)
+
+de_loc :: [(SrcLoc, a)] -> [a]
+de_loc = map snd
+
+----------------------------------------------------------
-- The meta-environment
+-- A name/identifier association for fresh names of locally bound entities
+--
type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
-- I.e. (x, x_id) means
-- let x_id = gensym "x" in ...
-addBinds :: [GenSymBind] -> DsM a -> DsM a
-addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
-
+-- Generate a fresh name for a locally bound entity
+--
mkGenSym :: Name -> DsM GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
+-- Ditto for a list of names
+--
mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
+-- Add a list of fresh names for locally bound entities to the meta
+-- environment (which is part of the state carried around by the desugarer
+-- monad)
+--
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
+
+-- Look up a locally bound name
+--
lookupBinder :: Name -> DsM (Core String)
lookupBinder n
= do { mb_val <- dsLookupMetaEnv n;
Just (Bound x) -> return (coreVar x)
other -> pprPanic "Failed binder lookup:" (ppr n) }
+-- Look up a name that is either locally bound or a global name
+--
+-- * If it is a global name, generate the "original name" representation (ie,
+-- the <module>:<name> form) for the associated entity
+--
lookupOcc :: Name -> DsM (Core String)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
localVar :: Name -> DsM (Core String)
localVar n = coreStringLit (occNameUserString (nameOccName n))
-lookupType :: Name -- Name of type constructor (e.g. M.Expr)
+lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
-> DsM Type -- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
return (mkGenTyConApp tc []) }
-- bindQ (gensym nm2 (\ id2 ->
-- y))
-wrapGenSyns :: Name -- Name of the type (consructor) for 'a'
- -> [GenSymBind]
+wrapGenSyns :: [GenSymBind]
-> Core (M.Q a) -> DsM (Core (M.Q a))
-wrapGenSyns tc_name binds body@(MkC b)
- = do { elt_ty <- lookupType tc_name
- ; go elt_ty binds }
+wrapGenSyns binds body@(MkC b)
+ = go binds
where
- go elt_ty [] = return body
- go elt_ty ((name,id) : binds)
- = do { MkC body' <- go elt_ty binds
+ [elt_ty] = tcTyConAppArgs (exprType b)
+ -- b :: Q a, so we can get the type 'a' by looking at the
+ -- argument type. NB: this relies on Q being a data/newtype,
+ -- not a type synonym
+
+ go [] = return body
+ go ((name,id) : binds)
+ = do { MkC body' <- go binds
; lit_str <- localVar name
; gensym_app <- repGensym lit_str
; repBindQ stringTy elt_ty
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
-wrapNongenSyms :: [GenSymBind]
- -> Core [M.Decl] -> DsM (Core [M.Decl])
-wrapNongenSyms binds body@(MkC b)
- = go binds
+wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
+wrapNongenSyms binds (MkC body)
+ = do { binds' <- mapM do_one binds ;
+ return (MkC (mkLets binds' body)) }
where
- go [] = return body
- go ((name,id) : binds)
- = do { MkC body' <- go binds
- ; MkC lit_str <- localVar name -- No gensym
- ; return (MkC (Let (NonRec id lit_str) body'))
- }
+ do_one (name,id)
+ = do { MkC lit_str <- localVar name -- No gensym
+ ; return (NonRec id lit_str) }
void = placeHolderType
-- %*********************************************************************
--------------- Patterns -----------------
-repPlit :: Core M.Lit -> DsM (Core M.Patt)
+repPlit :: Core M.Lit -> DsM (Core M.Pat)
repPlit (MkC l) = rep2 plitName [l]
-repPvar :: Core String -> DsM (Core M.Patt)
+repPvar :: Core String -> DsM (Core M.Pat)
repPvar (MkC s) = rep2 pvarName [s]
-repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
+repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
repPtup (MkC ps) = rep2 ptupName [ps]
-repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
+repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
-repPtilde :: Core M.Patt -> DsM (Core M.Patt)
+repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
+repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
+
+repPtilde :: Core M.Pat -> DsM (Core M.Pat)
repPtilde (MkC p) = rep2 ptildeName [p]
-repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
+repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
-repPwild :: DsM (Core M.Patt)
+repPwild :: DsM (Core M.Pat)
repPwild = rep2 pwildName []
--------------- Expressions -----------------
-repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
+repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
| otherwise = repVar str
-repVar :: Core String -> DsM (Core M.Expr)
+repVar :: Core String -> DsM (Core M.ExpQ)
repVar (MkC s) = rep2 varName [s]
-repCon :: Core String -> DsM (Core M.Expr)
+repCon :: Core String -> DsM (Core M.ExpQ)
repCon (MkC s) = rep2 conName [s]
-repLit :: Core M.Lit -> DsM (Core M.Expr)
+repLit :: Core M.Lit -> DsM (Core M.ExpQ)
repLit (MkC c) = rep2 litName [c]
-repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
repApp (MkC x) (MkC y) = rep2 appName [x,y]
-repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
+repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
-repTup :: Core [M.Expr] -> DsM (Core M.Expr)
+repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
repTup (MkC es) = rep2 tupName [es]
-repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
-repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
+repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
+repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
+repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
repDoE (MkC ss) = rep2 doEName [ss]
-repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
+repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
repComp (MkC ss) = rep2 compName [ss]
-repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
+repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
repListExp (MkC es) = rep2 listExpName [es]
-repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
+repSigExp :: Core M.ExpQ -> Core M.TypQ -> DsM (Core M.ExpQ)
repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
-repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
-repNeg :: Core M.Expr -> DsM (Core M.Expr)
-repNeg (MkC x) = rep2 negName [x]
+repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
-repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
-repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
------------ Right hand sides (guarded expressions) ----
-repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
+repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.RHSQ)
repGuarded (MkC pairs) = rep2 guardedName [pairs]
-repNormal :: Core M.Expr -> DsM (Core M.Rihs)
+repNormal :: Core M.ExpQ -> DsM (Core M.RHSQ)
repNormal (MkC e) = rep2 normalName [e]
-------------- Statements -------------------
-repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
+------------- Stmts -------------------
+repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ)
repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
-repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
+repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ)
repLetSt (MkC ds) = rep2 letStName [ds]
-repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
+repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ)
repNoBindSt (MkC e) = rep2 noBindStName [e]
-------------- DotDot (Arithmetic sequences) -----------
-repFrom :: Core M.Expr -> DsM (Core M.Expr)
+repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
repFrom (MkC x) = rep2 fromName [x]
-repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
-repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
-repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
------------ Match and Clause Tuples -----------
-repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
+repMatch :: Core M.Pat -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
+repClause :: Core [M.Pat] -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-------------- Dec -----------------------------
-repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
+repVal :: Core M.Pat -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
-repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
+repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
-repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
-repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
+repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
+repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
+
+repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ)
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs) = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
+
+repTySyn :: Core String -> Core [String] -> Core M.TypQ -> DsM (Core M.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
-repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
+repInst :: Core M.CxtQ -> Core M.TypQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
-repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
+repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ)
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
-repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
+repProto :: Core String -> Core M.TypQ -> DsM (Core M.DecQ)
repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
-repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
-repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
+repCtxt :: Core [M.TypQ] -> DsM (Core M.CxtQ)
+repCtxt (MkC tys) = rep2 ctxtName [tys]
+
+repConstr :: Core String -> HsConDetails Name (BangType Name)
+ -> DsM (Core M.ConQ)
+repConstr con (PrefixCon ps)
+ = do arg_tys <- mapM repBangTy ps
+ arg_tys1 <- coreList strTypeTyConName arg_tys
+ rep2 constrName [unC con, unC arg_tys1]
+repConstr con (RecCon ips)
+ = do arg_vs <- mapM lookupOcc (map fst ips)
+ arg_tys <- mapM repBangTy (map snd ips)
+ arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
+ arg_vs arg_tys
+ arg_vtys' <- coreList varStrTypeTyConName arg_vtys
+ rep2 recConstrName [unC con, unC arg_vtys']
+repConstr con (InfixCon st1 st2)
+ = do arg1 <- repBangTy st1
+ arg2 <- repBangTy st2
+ rep2 infixConstrName [unC arg1, unC con, unC arg2]
------------ Types -------------------
-repTvar :: Core String -> DsM (Core M.Type)
+repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypQ -> DsM (Core M.TypQ)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty]
+
+repTvar :: Core String -> DsM (Core M.TypQ)
repTvar (MkC s) = rep2 tvarName [s]
-repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
+repTapp :: Core M.TypQ -> Core M.TypQ -> DsM (Core M.TypQ)
repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
-repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
+repTapps :: Core M.TypQ -> [Core M.TypQ] -> DsM (Core M.TypQ)
repTapps f [] = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
--------- Type constructors --------------
-repNamedTyCon :: Core String -> DsM (Core M.Type)
+repNamedTyCon :: Core String -> DsM (Core M.TypQ)
repNamedTyCon (MkC s) = rep2 namedTyConName [s]
-repTupleTyCon :: Int -> DsM (Core M.Type)
+repTupleTyCon :: Int -> DsM (Core M.TypQ)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
-repArrowTyCon :: DsM (Core M.Type)
+repArrowTyCon :: DsM (Core M.TypQ)
repArrowTyCon = rep2 arrowTyConName []
-repListTyCon :: DsM (Core M.Type)
+repListTyCon :: DsM (Core M.TypQ)
repListTyCon = rep2 listTyConName []
repLiteral :: HsLit -> DsM (Core M.Lit)
repLiteral lit
- = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
+ = do lit' <- case lit of
+ HsIntPrim i -> return $ HsInteger i
+ HsInt i -> return $ HsInteger i
+ HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName
+ return $ HsRat r rat_ty
+ HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName
+ return $ HsRat r rat_ty
+ _ -> return lit
+ lit_expr <- dsLit lit'
+ rep2 lit_name [lit_expr]
where
lit_name = case lit of
- HsInt _ -> intLName
- HsChar _ -> charLName
- HsString _ -> stringLName
- HsRat _ _ -> rationalLName
- other -> uh_oh
+ HsInteger _ -> integerLName
+ HsInt _ -> integerLName
+ HsIntPrim _ -> intPrimLName
+ HsFloatPrim _ -> floatPrimLName
+ HsDoublePrim _ -> doublePrimLName
+ HsChar _ -> charLName
+ HsString _ -> stringLName
+ HsRat _ _ -> rationalLName
+ other -> uh_oh
uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
(ppr lit)
repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
-repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInt i)
+repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i)
repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
repLiteral (HsRat f rat_ty) }
-- The type Rational will be in the environment, becuase
--------------- Miscellaneous -------------------
-repLift :: Core e -> DsM (Core M.Expr)
+repLift :: Core e -> DsM (Core M.ExpQ)
repLift (MkC x) = rep2 liftName [x]
repGensym :: Core String -> DsM (Core (M.Q String))
repBindQ ty_a ty_b (MkC x) (MkC y)
= rep2 bindQName [Type ty_a, Type ty_b, x, y]
+repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
+repSequenceQ ty_a (MkC list)
+ = rep2 sequenceQName [Type ty_a, list]
+
------------ Lists and Tuples -------------------
-- turn a list of patterns into a single pattern matching a list
-- The names that are implicitly mentioned by ``bracket''
-- Should stay in sync with the import list of DsMeta
templateHaskellNames
- = mkNameSet [ intLName,charLName, stringLName, rationalLName,
+ = mkNameSet [ intPrimLName, floatPrimLName, doublePrimLName,
+ integerLName, charLName, stringLName, rationalLName,
plitName, pvarName, ptupName,
pconName, ptildeName, paspatName, pwildName,
varName, conName, litName, appName, infixEName, lamName,
tupName, doEName, compName,
listExpName, sigExpName, condName, letEName, caseEName,
- infixAppName, negName, sectionLName, sectionRName,
+ infixAppName, sectionLName, sectionRName,
guardedName, normalName,
bindStName, letStName, noBindStName, parStName,
fromName, fromThenName, fromToName, fromThenToName,
funName, valName, liftName,
- gensymName, returnQName, bindQName,
- matchName, clauseName, funName, valName, dataDName, classDName,
- instName, protoName, tvarName, tconName, tappName,
+ gensymName, returnQName, bindQName, sequenceQName,
+ matchName, clauseName, funName, valName, tySynDName, dataDName, newtypeDName, classDName,
+ instName, protoName, tforallName, tvarName, tconName, tappName,
arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
- constrName,
+ ctxtName, constrName, recConstrName, infixConstrName,
exprTyConName, declTyConName, pattTyConName, mtchTyConName,
clseTyConName, stmtTyConName, consTyConName, typeTyConName,
+ strTypeTyConName, varStrTypeTyConName,
qTyConName, expTyConName, matTyConName, clsTyConName,
- decTyConName, typTyConName ]
+ decTyConName, typTyConName, strictTypeName, varStrictTypeName,
+ recConName, recUpdName, precName,
+ fieldName, fieldTyConName, fieldPName, fieldPTyConName,
+ strictName, nonstrictName ]
varQual = mk_known_key_name OccName.varName
mk_known_key_name space str uniq
= mkKnownKeyExternalName thModule (mkOccFS space str) uniq
-intLName = varQual FSLIT("intL") intLIdKey
-charLName = varQual FSLIT("charL") charLIdKey
-stringLName = varQual FSLIT("stringL") stringLIdKey
-rationalLName = varQual FSLIT("rationalL") rationalLIdKey
-plitName = varQual FSLIT("plit") plitIdKey
-pvarName = varQual FSLIT("pvar") pvarIdKey
-ptupName = varQual FSLIT("ptup") ptupIdKey
-pconName = varQual FSLIT("pcon") pconIdKey
-ptildeName = varQual FSLIT("ptilde") ptildeIdKey
-paspatName = varQual FSLIT("paspat") paspatIdKey
-pwildName = varQual FSLIT("pwild") pwildIdKey
-varName = varQual FSLIT("var") varIdKey
-conName = varQual FSLIT("con") conIdKey
-litName = varQual FSLIT("lit") litIdKey
-appName = varQual FSLIT("app") appIdKey
-infixEName = varQual FSLIT("infixE") infixEIdKey
-lamName = varQual FSLIT("lam") lamIdKey
-tupName = varQual FSLIT("tup") tupIdKey
-doEName = varQual FSLIT("doE") doEIdKey
-compName = varQual FSLIT("comp") compIdKey
+intPrimLName = varQual FSLIT("intPrimLit") intPrimLIdKey
+floatPrimLName = varQual FSLIT("floatPrimLit") floatPrimLIdKey
+doublePrimLName = varQual FSLIT("doublePrimLit") doublePrimLIdKey
+integerLName = varQual FSLIT("integerLit") integerLIdKey
+charLName = varQual FSLIT("charLit") charLIdKey
+stringLName = varQual FSLIT("stringLit") stringLIdKey
+rationalLName = varQual FSLIT("rationalLit") rationalLIdKey
+plitName = varQual FSLIT("litPat") plitIdKey
+pvarName = varQual FSLIT("varPat") pvarIdKey
+ptupName = varQual FSLIT("tupPat") ptupIdKey
+pconName = varQual FSLIT("conPat") pconIdKey
+ptildeName = varQual FSLIT("tildePat") ptildeIdKey
+paspatName = varQual FSLIT("asPat") paspatIdKey
+pwildName = varQual FSLIT("wildPat") pwildIdKey
+precName = varQual FSLIT("recPat") precIdKey
+varName = varQual FSLIT("varExp") varIdKey
+conName = varQual FSLIT("conExp") conIdKey
+litName = varQual FSLIT("litExp") litIdKey
+appName = varQual FSLIT("appExp") appIdKey
+infixEName = varQual FSLIT("infixExp") infixEIdKey
+lamName = varQual FSLIT("lamExp") lamIdKey
+tupName = varQual FSLIT("tupExp") tupIdKey
+doEName = varQual FSLIT("doExp") doEIdKey
+compName = varQual FSLIT("compExp") compIdKey
listExpName = varQual FSLIT("listExp") listExpIdKey
sigExpName = varQual FSLIT("sigExp") sigExpIdKey
-condName = varQual FSLIT("cond") condIdKey
-letEName = varQual FSLIT("letE") letEIdKey
-caseEName = varQual FSLIT("caseE") caseEIdKey
+condName = varQual FSLIT("condExp") condIdKey
+letEName = varQual FSLIT("letExp") letEIdKey
+caseEName = varQual FSLIT("caseExp") caseEIdKey
infixAppName = varQual FSLIT("infixApp") infixAppIdKey
-negName = varQual FSLIT("neg") negIdKey
sectionLName = varQual FSLIT("sectionL") sectionLIdKey
sectionRName = varQual FSLIT("sectionR") sectionRIdKey
-guardedName = varQual FSLIT("guarded") guardedIdKey
-normalName = varQual FSLIT("normal") normalIdKey
-bindStName = varQual FSLIT("bindSt") bindStIdKey
-letStName = varQual FSLIT("letSt") letStIdKey
-noBindStName = varQual FSLIT("noBindSt") noBindStIdKey
-parStName = varQual FSLIT("parSt") parStIdKey
-fromName = varQual FSLIT("from") fromIdKey
-fromThenName = varQual FSLIT("fromThen") fromThenIdKey
-fromToName = varQual FSLIT("fromTo") fromToIdKey
-fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey
+recConName = varQual FSLIT("recConExp") recConIdKey
+recUpdName = varQual FSLIT("recUpdExp") recUpdIdKey
+guardedName = varQual FSLIT("guardedRHS") guardedIdKey
+normalName = varQual FSLIT("normalRHS") normalIdKey
+bindStName = varQual FSLIT("bindStmt") bindStIdKey
+letStName = varQual FSLIT("letStmt") letStIdKey
+noBindStName = varQual FSLIT("noBindStmt") noBindStIdKey
+parStName = varQual FSLIT("parStmt") parStIdKey
+fromName = varQual FSLIT("fromExp") fromIdKey
+fromThenName = varQual FSLIT("fromThenExp") fromThenIdKey
+fromToName = varQual FSLIT("fromToExp") fromToIdKey
+fromThenToName = varQual FSLIT("fromThenToExp") fromThenToIdKey
liftName = varQual FSLIT("lift") liftIdKey
gensymName = varQual FSLIT("gensym") gensymIdKey
returnQName = varQual FSLIT("returnQ") returnQIdKey
bindQName = varQual FSLIT("bindQ") bindQIdKey
+sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
--- type Mat = ...
+-- data Match = ...
matchName = varQual FSLIT("match") matchIdKey
--- type Cls = ...
+-- data Clause = ...
clauseName = varQual FSLIT("clause") clauseIdKey
-- data Dec = ...
-funName = varQual FSLIT("fun") funIdKey
-valName = varQual FSLIT("val") valIdKey
-dataDName = varQual FSLIT("dataD") dataDIdKey
-classDName = varQual FSLIT("classD") classDIdKey
-instName = varQual FSLIT("inst") instIdKey
-protoName = varQual FSLIT("proto") protoIdKey
+funName = varQual FSLIT("funDec") funIdKey
+valName = varQual FSLIT("valDec") valIdKey
+dataDName = varQual FSLIT("dataDec") dataDIdKey
+newtypeDName = varQual FSLIT("newtypeDec") newtypeDIdKey
+tySynDName = varQual FSLIT("tySynDec") tySynDIdKey
+classDName = varQual FSLIT("classDec") classDIdKey
+instName = varQual FSLIT("instanceDec") instIdKey
+protoName = varQual FSLIT("sigDec") protoIdKey
-- data Typ = ...
-tvarName = varQual FSLIT("tvar") tvarIdKey
-tconName = varQual FSLIT("tcon") tconIdKey
-tappName = varQual FSLIT("tapp") tappIdKey
+tforallName = varQual FSLIT("forallTyp") tforallIdKey
+tvarName = varQual FSLIT("varTyp") tvarIdKey
+tconName = varQual FSLIT("conTyp") tconIdKey
+tappName = varQual FSLIT("appTyp") tappIdKey
-- data Tag = ...
-arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
-tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
-listTyConName = varQual FSLIT("listTyCon") listIdKey
-namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
+arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
+tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
+listTyConName = varQual FSLIT("listTyCon") listIdKey
+namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
+
+-- type Ctxt = ...
+ctxtName = varQual FSLIT("cxt") ctxtIdKey
-- data Con = ...
-constrName = varQual FSLIT("constr") constrIdKey
-
-exprTyConName = tcQual FSLIT("Expr") exprTyConKey
-declTyConName = tcQual FSLIT("Decl") declTyConKey
-pattTyConName = tcQual FSLIT("Patt") pattTyConKey
-mtchTyConName = tcQual FSLIT("Mtch") mtchTyConKey
-clseTyConName = tcQual FSLIT("Clse") clseTyConKey
-stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
-consTyConName = tcQual FSLIT("Cons") consTyConKey
-typeTyConName = tcQual FSLIT("Type") typeTyConKey
+constrName = varQual FSLIT("normalCon") constrIdKey
+recConstrName = varQual FSLIT("recCon") recConstrIdKey
+infixConstrName = varQual FSLIT("infixCon") infixConstrIdKey
+exprTyConName = tcQual FSLIT("ExpQ") exprTyConKey
+declTyConName = tcQual FSLIT("DecQ") declTyConKey
+pattTyConName = tcQual FSLIT("Pat") pattTyConKey
+mtchTyConName = tcQual FSLIT("MatchQ") mtchTyConKey
+clseTyConName = tcQual FSLIT("ClauseQ") clseTyConKey
+stmtTyConName = tcQual FSLIT("StmtQ") stmtTyConKey
+consTyConName = tcQual FSLIT("ConQ") consTyConKey
+typeTyConName = tcQual FSLIT("TypQ") typeTyConKey
+strTypeTyConName = tcQual FSLIT("StrictTypQ") strTypeTyConKey
+varStrTypeTyConName = tcQual FSLIT("VarStrictTypQ") varStrTypeTyConKey
+
+fieldTyConName = tcQual FSLIT("FieldExp") fieldTyConKey
+fieldPTyConName = tcQual FSLIT("FieldPat") fieldPTyConKey
+
qTyConName = tcQual FSLIT("Q") qTyConKey
expTyConName = tcQual FSLIT("Exp") expTyConKey
decTyConName = tcQual FSLIT("Dec") decTyConKey
typTyConName = tcQual FSLIT("Typ") typTyConKey
-matTyConName = tcQual FSLIT("Mat") matTyConKey
-clsTyConName = tcQual FSLIT("Cls") clsTyConKey
+matTyConName = tcQual FSLIT("Match") matTyConKey
+clsTyConName = tcQual FSLIT("Clause") clsTyConKey
+
+strictTypeName = varQual FSLIT("strictTypQ") strictTypeKey
+varStrictTypeName = varQual FSLIT("varStrictTypQ") varStrictTypeKey
+strictName = varQual FSLIT("isStrict") strictKey
+nonstrictName = varQual FSLIT("notStrict") nonstrictKey
+
+fieldName = varQual FSLIT("fieldExp") fieldKey
+fieldPName = varQual FSLIT("fieldPat") fieldPKey
-- TyConUniques available: 100-119
-- Check in PrelNames if you want to change this
typeTyConKey = mkPreludeTyConUnique 111
typTyConKey = mkPreludeTyConUnique 112
decTyConKey = mkPreludeTyConUnique 113
+varStrTypeTyConKey = mkPreludeTyConUnique 114
+strTypeTyConKey = mkPreludeTyConUnique 115
+fieldTyConKey = mkPreludeTyConUnique 116
+fieldPTyConKey = mkPreludeTyConUnique 117
protoIdKey = mkPreludeMiscIdUnique 210
matchIdKey = mkPreludeMiscIdUnique 211
clauseIdKey = mkPreludeMiscIdUnique 212
-intLIdKey = mkPreludeMiscIdUnique 213
+integerLIdKey = mkPreludeMiscIdUnique 213
charLIdKey = mkPreludeMiscIdUnique 214
classDIdKey = mkPreludeMiscIdUnique 215
instIdKey = mkPreludeMiscIdUnique 216
dataDIdKey = mkPreludeMiscIdUnique 217
+sequenceQIdKey = mkPreludeMiscIdUnique 218
+tySynDIdKey = mkPreludeMiscIdUnique 219
plitIdKey = mkPreludeMiscIdUnique 220
pvarIdKey = mkPreludeMiscIdUnique 221
letEIdKey = mkPreludeMiscIdUnique 239
caseEIdKey = mkPreludeMiscIdUnique 240
infixAppIdKey = mkPreludeMiscIdUnique 241
-negIdKey = mkPreludeMiscIdUnique 242
+-- 242 unallocated
sectionLIdKey = mkPreludeMiscIdUnique 243
sectionRIdKey = mkPreludeMiscIdUnique 244
guardedIdKey = mkPreludeMiscIdUnique 245
noBindStIdKey = mkPreludeMiscIdUnique 249
parStIdKey = mkPreludeMiscIdUnique 250
-tvarIdKey = mkPreludeMiscIdUnique 251
-tconIdKey = mkPreludeMiscIdUnique 252
-tappIdKey = mkPreludeMiscIdUnique 253
+tforallIdKey = mkPreludeMiscIdUnique 251
+tvarIdKey = mkPreludeMiscIdUnique 252
+tconIdKey = mkPreludeMiscIdUnique 253
+tappIdKey = mkPreludeMiscIdUnique 254
+
+arrowIdKey = mkPreludeMiscIdUnique 255
+tupleIdKey = mkPreludeMiscIdUnique 256
+listIdKey = mkPreludeMiscIdUnique 257
+namedTyConIdKey = mkPreludeMiscIdUnique 258
+
+ctxtIdKey = mkPreludeMiscIdUnique 259
+
+constrIdKey = mkPreludeMiscIdUnique 260
+
+stringLIdKey = mkPreludeMiscIdUnique 261
+rationalLIdKey = mkPreludeMiscIdUnique 262
-arrowIdKey = mkPreludeMiscIdUnique 254
-tupleIdKey = mkPreludeMiscIdUnique 255
-listIdKey = mkPreludeMiscIdUnique 256
-namedTyConIdKey = mkPreludeMiscIdUnique 257
+sigExpIdKey = mkPreludeMiscIdUnique 263
-constrIdKey = mkPreludeMiscIdUnique 258
+strictTypeKey = mkPreludeMiscIdUnique 264
+strictKey = mkPreludeMiscIdUnique 265
+nonstrictKey = mkPreludeMiscIdUnique 266
+varStrictTypeKey = mkPreludeMiscIdUnique 267
-stringLIdKey = mkPreludeMiscIdUnique 259
-rationalLIdKey = mkPreludeMiscIdUnique 260
+recConstrIdKey = mkPreludeMiscIdUnique 268
+infixConstrIdKey = mkPreludeMiscIdUnique 269
-sigExpIdKey = mkPreludeMiscIdUnique 261
+recConIdKey = mkPreludeMiscIdUnique 270
+recUpdIdKey = mkPreludeMiscIdUnique 271
+precIdKey = mkPreludeMiscIdUnique 272
+fieldKey = mkPreludeMiscIdUnique 273
+fieldPKey = mkPreludeMiscIdUnique 274
+intPrimLIdKey = mkPreludeMiscIdUnique 275
+floatPrimLIdKey = mkPreludeMiscIdUnique 276
+doublePrimLIdKey = mkPreludeMiscIdUnique 277
+newtypeDIdKey = mkPreludeMiscIdUnique 278
-- %************************************************************************
-- %* *
-- It is rather usatisfactory that we don't have a SrcLoc
addDsWarn :: SDoc -> DsM ()
-addDsWarn msg = dsWarn (noSrcLoc, msg)
\ No newline at end of file
+addDsWarn msg = dsWarn (noSrcLoc, msg)
projects / ghc-hetmet.git / blobdiff