import OccName ( mkOccFS )
import NameEnv
import NameSet
-import Type ( Type, TyThing(..), mkGenTyConApp )
-import TcType ( tcTyConAppArgs )
+import Type ( Type, mkGenTyConApp )
+import TcType ( TyThing(..), tcTyConAppArgs )
import TyCon ( DataConDetails(..) )
import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils ( exprType )
import SrcLoc ( noSrcLoc )
+import Maybes ( orElse )
import Maybe ( catMaybes, fromMaybe )
import Panic ( panic )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
import Outputable
import FastString ( mkFastString )
+
+import Monad ( zipWithM )
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
-- 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 {
decl_ty <- lookupType declTyConName ;
let { core_list = coreList' decl_ty decls } ;
- q_decs <- repSequenceQ decl_ty 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 (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]
dec <- addTyVarBinds tvs $ \bndrs -> do {
- cons1 <- mapM repC cons ;
+ cxt1 <- repContext cxt ;
+ cons1 <- mapM repC cons ;
cons2 <- coreList consTyConName cons1 ;
derivs1 <- repDerivs mb_derivs ;
- repData tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
+ repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
return $ Just dec }
repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
return (Just dec) }
repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
- tcdTyVars = tvs, tcdFDs = [],
- tcdSigs = sigs, tcdMeths = Just binds }) =
- do
- cls1 <- lookupOcc cls -- See note [Binders and occurrences]
- dec <- addTyVarBinds tvs $ \bndrs -> do
- cxt1 <- repContext cxt
- sigs1 <- rep_sigs sigs
- binds1 <- rep_monobind binds
- decls1 <- coreList declTyConName (sigs1 ++ binds1)
- repClass cxt1 cls1 (coreList' stringTy bndrs) decls1
- return $ Just dec
+ tcdTyVars = tvs,
+ tcdFDs = [], -- We don't understand functional dependencies
+ tcdSigs = sigs, tcdMeths = mb_meth_binds })
+ = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
+ 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 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)) ;
repC :: ConDecl Name -> DsM (Core M.Cons)
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.Q (M.Strictness, M.Typ)))
+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
rep_sig (Sig nm ty _) = rep_proto nm ty
rep_sig other = return []
-rep_proto nm ty = do { nm1 <- lookupBinder nm ;
+rep_proto nm ty = do { nm1 <- lookupOcc nm ;
ty1 <- repTy ty ;
sig <- repProto nm1 ty1 ;
return [sig] }
-- Types
-------------------------------------------------------
--- represent a list of type variables in a usage position that does not need
--- gensym'ing
---
-repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
-repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
- return (coreList' stringTy tvs1) }
-
-- 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 *original* names as an argument
+-- 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
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"
+ 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
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 (ArithSeqIn aseq) =
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 _ _) =
= 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.FldE])
+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
= 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 _)))"
repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
+repPrec :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt)
+repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
+
repPtilde :: Core M.Patt -> DsM (Core M.Patt)
repPtilde (MkC p) = rep2 ptildeName [p]
repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
-repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
+repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr)
+repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
+
+repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
+
+repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
+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 (MkC x) (MkC y) = rep2 sectionRName [x,y]
------------ Right hand sides (guarded expressions) ----
repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
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.Ctxt -> Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
+repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
repTySyn :: Core String -> Core [String] -> Core M.Type -> DsM (Core M.Decl)
repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt)
repCtxt (MkC tys) = rep2 ctxtName [tys]
-repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
-repConstr (MkC con) (MkC tys) = rep2 constrName [con, tys]
+repConstr :: Core String -> HsConDetails Name (BangType Name)
+ -> DsM (Core M.Cons)
+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 -------------------
matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
instName, protoName, tforallName, tvarName, tconName, tappName,
arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
- ctxtName, 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
ptildeName = varQual FSLIT("ptilde") ptildeIdKey
paspatName = varQual FSLIT("paspat") paspatIdKey
pwildName = varQual FSLIT("pwild") pwildIdKey
+precName = varQual FSLIT("prec") precIdKey
varName = varQual FSLIT("var") varIdKey
conName = varQual FSLIT("con") conIdKey
litName = varQual FSLIT("lit") litIdKey
infixAppName = varQual FSLIT("infixApp") infixAppIdKey
sectionLName = varQual FSLIT("sectionL") sectionLIdKey
sectionRName = varQual FSLIT("sectionR") sectionRIdKey
+recConName = varQual FSLIT("recCon") recConIdKey
+recUpdName = varQual FSLIT("recUpd") recUpdIdKey
guardedName = varQual FSLIT("guarded") guardedIdKey
normalName = varQual FSLIT("normal") normalIdKey
bindStName = varQual FSLIT("bindSt") bindStIdKey
-- data Con = ...
constrName = varQual FSLIT("constr") constrIdKey
+recConstrName = varQual FSLIT("recConstr") recConstrIdKey
+infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey
exprTyConName = tcQual FSLIT("Expr") exprTyConKey
declTyConName = tcQual FSLIT("Decl") declTyConKey
stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
consTyConName = tcQual FSLIT("Cons") consTyConKey
typeTyConName = tcQual FSLIT("Type") typeTyConKey
-
+strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey
+varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey
+
+fieldTyConName = tcQual FSLIT("FldE") fieldTyConKey
+fieldPTyConName = tcQual FSLIT("FldP") fieldPTyConKey
+
qTyConName = tcQual FSLIT("Q") qTyConKey
expTyConName = tcQual FSLIT("Exp") expTyConKey
decTyConName = tcQual FSLIT("Dec") decTyConKey
matTyConName = tcQual FSLIT("Mat") matTyConKey
clsTyConName = tcQual FSLIT("Cls") clsTyConKey
+strictTypeName = varQual FSLIT("strictType") strictTypeKey
+varStrictTypeName = varQual FSLIT("varStrictType") varStrictTypeKey
+strictName = varQual FSLIT("strict") strictKey
+nonstrictName = varQual FSLIT("nonstrict") nonstrictKey
+
+fieldName = varQual FSLIT("field") fieldKey
+fieldPName = varQual FSLIT("fieldP") 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
sigExpIdKey = mkPreludeMiscIdUnique 263
+strictTypeKey = mkPreludeMiscIdUnique 264
+strictKey = mkPreludeMiscIdUnique 265
+nonstrictKey = mkPreludeMiscIdUnique 266
+varStrictTypeKey = mkPreludeMiscIdUnique 267
+
+recConstrIdKey = mkPreludeMiscIdUnique 268
+infixConstrIdKey = mkPreludeMiscIdUnique 269
+
+recConIdKey = mkPreludeMiscIdUnique 270
+recUpdIdKey = mkPreludeMiscIdUnique 271
+precIdKey = mkPreludeMiscIdUnique 272
+fieldKey = mkPreludeMiscIdUnique 273
+fieldPKey = mkPreludeMiscIdUnique 274
-- %************************************************************************
-- 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