module DsMeta( dsBracket, dsReify,
templateHaskellNames, qTyConName,
- liftName, expQTyConName, decQTyConName, typQTyConName,
- decTyConName, typTyConName ) where
+ liftName, expQTyConName, decQTyConName, typeQTyConName,
+ decTyConName, typeTyConName ) where
#include "HsVersions.h"
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
--- Returns a CoreExpr of type reifyType --> M.TypQ
+-- Returns a CoreExpr of type reifyType --> M.TypeQ
-- reifyDecl --> M.DecQ
-- reifyFixty --> Q M.Fix
dsReify (ReifyOut ReifyType name)
= do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
-repBangTy :: BangType Name -> DsM (Core (M.StrictTypQ))
+repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ))
repBangTy (BangType str ty) = do MkC s <- rep2 strName []
MkC t <- repTy ty
- rep2 strictTypName [s, t]
+ rep2 strictTypeName [s, t]
where strName = case str of
NotMarkedStrict -> notStrictName
_ -> isStrictName
repContext :: HsContext Name -> DsM (Core M.CxtQ)
repContext ctxt = do
preds <- mapM repPred ctxt
- predList <- coreList typQTyConName preds
+ predList <- coreList typeQTyConName preds
repCtxt predList
-- represent a type predicate
--
-repPred :: HsPred Name -> DsM (Core M.TypQ)
+repPred :: HsPred Name -> DsM (Core M.TypeQ)
repPred (HsClassP cls tys) = do
tcon <- repTy (HsTyVar cls)
tys1 <- repTys tys
-- yield the representation of a list of types
--
-repTys :: [HsType Name] -> DsM [Core M.TypQ]
+repTys :: [HsType Name] -> DsM [Core M.TypeQ]
repTys tys = mapM repTy tys
-- represent a type
--
-repTy :: HsType Name -> DsM (Core M.TypQ)
+repTy :: HsType Name -> DsM (Core M.TypeQ)
repTy (HsForAllTy bndrs ctxt ty) =
addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
ctxt' <- repContext ctxt
; clause <- repClause ps1 gs ds
; wrapGenSyns (ss1++ss2) clause }}}
-repGuards :: [GRHS Name] -> DsM (Core M.RHSQ)
+repGuards :: [GRHS Name] -> DsM (Core M.BodyQ)
repGuards [GRHS [ResultStmt e loc] loc2]
= do {a <- repE e; repNormal a }
repGuards other
--------------- Patterns -----------------
repPlit :: Core M.Lit -> DsM (Core M.Pat)
-repPlit (MkC l) = rep2 litPatName [l]
+repPlit (MkC l) = rep2 litPName [l]
repPvar :: Core String -> DsM (Core M.Pat)
-repPvar (MkC s) = rep2 varPatName [s]
+repPvar (MkC s) = rep2 varPName [s]
repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
-repPtup (MkC ps) = rep2 tupPatName [ps]
+repPtup (MkC ps) = rep2 tupPName [ps]
repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
-repPcon (MkC s) (MkC ps) = rep2 conPatName [s, ps]
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
-repPrec (MkC c) (MkC rps) = rep2 recPatName [c,rps]
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
repPtilde :: Core M.Pat -> DsM (Core M.Pat)
-repPtilde (MkC p) = rep2 tildePatName [p]
+repPtilde (MkC p) = rep2 tildePName [p]
repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
-repPaspat (MkC s) (MkC p) = rep2 asPatName [s, p]
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
repPwild :: DsM (Core M.Pat)
-repPwild = rep2 wildPatName []
+repPwild = rep2 wildPName []
--------------- Expressions -----------------
repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
| otherwise = repVar str
repVar :: Core String -> DsM (Core M.ExpQ)
-repVar (MkC s) = rep2 varExpName [s]
+repVar (MkC s) = rep2 varEName [s]
repCon :: Core String -> DsM (Core M.ExpQ)
-repCon (MkC s) = rep2 conExpName [s]
+repCon (MkC s) = rep2 conEName [s]
repLit :: Core M.Lit -> DsM (Core M.ExpQ)
-repLit (MkC c) = rep2 litExpName [c]
+repLit (MkC c) = rep2 litEName [c]
repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repApp (MkC x) (MkC y) = rep2 appExpName [x,y]
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repLam (MkC ps) (MkC e) = rep2 lamExpName [ps, e]
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
-repTup (MkC es) = rep2 tupExpName [es]
+repTup (MkC es) = rep2 tupEName [es]
repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repCond (MkC x) (MkC y) (MkC z) = rep2 condExpName [x,y,z]
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repLetE (MkC ds) (MkC e) = rep2 letExpName [ds, e]
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
-repCaseE (MkC e) (MkC ms) = rep2 caseExpName [e, ms]
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
-repDoE (MkC ss) = rep2 doExpName [ss]
+repDoE (MkC ss) = rep2 doEName [ss]
repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
-repComp (MkC ss) = rep2 compExpName [ss]
+repComp (MkC ss) = rep2 compEName [ss]
repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
-repListExp (MkC es) = rep2 listExpName [es]
+repListExp (MkC es) = rep2 listEName [es]
-repSigExp :: Core M.ExpQ -> Core M.TypQ -> DsM (Core M.ExpQ)
-repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
+repSigExp :: Core M.ExpQ -> Core M.TypeQ -> DsM (Core M.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
-repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
+repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
-repRecUpd (MkC e) (MkC fs) = rep2 recUpdExpName [e,fs]
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
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]
repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
------------ Right hand sides (guarded expressions) ----
-repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.RHSQ)
-repGuarded (MkC pairs) = rep2 guardedRHSName [pairs]
+repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
-repNormal :: Core M.ExpQ -> DsM (Core M.RHSQ)
-repNormal (MkC e) = rep2 normalRHSName [e]
+repNormal :: Core M.ExpQ -> DsM (Core M.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
------------- Stmts -------------------
repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ)
-repBindSt (MkC p) (MkC e) = rep2 bindStmtName [p,e]
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ)
-repLetSt (MkC ds) = rep2 letStmtName [ds]
+repLetSt (MkC ds) = rep2 letSName [ds]
repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ)
-repNoBindSt (MkC e) = rep2 noBindStmtName [e]
+repNoBindSt (MkC e) = rep2 noBindSName [e]
--------------- DotDot (Arithmetic sequences) -----------
+-------------- Range (Arithmetic sequences) -----------
repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
-repFrom (MkC x) = rep2 fromExpName [x]
+repFrom (MkC x) = rep2 fromEName [x]
repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repFromThen (MkC x) (MkC y) = rep2 fromThenExpName [x,y]
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repFromTo (MkC x) (MkC y) = rep2 fromToExpName [x,y]
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToExpName [x,y,z]
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
------------ Match and Clause Tuples -----------
-repMatch :: Core M.Pat -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
+repMatch :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-repClause :: Core [M.Pat] -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
+repClause :: Core [M.Pat] -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-------------- Dec -----------------------------
-repVal :: Core M.Pat -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
-repVal (MkC p) (MkC b) (MkC ds) = rep2 valDecName [p, b, ds]
+repVal :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
-repFun (MkC nm) (MkC b) = rep2 funDecName [nm, b]
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
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 dataDecName [cxt, nm, tvs, cons, 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 newtypeDecName [cxt, nm, tvs, con, 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 tySynDecName [nm, tvs, rhs]
+repTySyn :: Core String -> Core [String] -> Core M.TypeQ -> DsM (Core M.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
-repInst :: Core M.CxtQ -> Core M.TypQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
-repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDecName [cxt, ty, ds]
+repInst :: Core M.CxtQ -> Core M.TypeQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
+repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
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 classDecName [cxt, cls, tvs, ds]
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
-repProto :: Core String -> Core M.TypQ -> DsM (Core M.DecQ)
-repProto (MkC s) (MkC ty) = rep2 sigDecName [s, ty]
+repProto :: Core String -> Core M.TypeQ -> DsM (Core M.DecQ)
+repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
-repCtxt :: Core [M.TypQ] -> DsM (Core M.CxtQ)
+repCtxt :: Core [M.TypeQ] -> DsM (Core M.CxtQ)
repCtxt (MkC tys) = rep2 cxtName [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 strictTypQTyConName arg_tys
- rep2 normalConName [unC con, unC arg_tys1]
+ arg_tys1 <- coreList strictTypeQTyConName arg_tys
+ rep2 normalCName [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 varStrictTypName [unC x, unC y])
+ arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
arg_vs arg_tys
- arg_vtys' <- coreList varStrictTypQTyConName arg_vtys
- rep2 recConName [unC con, unC arg_vtys']
+ arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
+ rep2 recCName [unC con, unC arg_vtys']
repConstr con (InfixCon st1 st2)
= do arg1 <- repBangTy st1
arg2 <- repBangTy st2
- rep2 infixConName [unC arg1, unC con, unC arg2]
+ rep2 infixCName [unC arg1, unC con, unC arg2]
------------ Types -------------------
-repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypQ -> DsM (Core M.TypQ)
+repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
repTForall (MkC tvars) (MkC ctxt) (MkC ty)
- = rep2 forallTypName [tvars, ctxt, ty]
+ = rep2 forallTName [tvars, ctxt, ty]
-repTvar :: Core String -> DsM (Core M.TypQ)
-repTvar (MkC s) = rep2 varTypName [s]
+repTvar :: Core String -> DsM (Core M.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
-repTapp :: Core M.TypQ -> Core M.TypQ -> DsM (Core M.TypQ)
-repTapp (MkC t1) (MkC t2) = rep2 appTypName [t1,t2]
+repTapp :: Core M.TypeQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
-repTapps :: Core M.TypQ -> [Core M.TypQ] -> DsM (Core M.TypQ)
+repTapps :: Core M.TypeQ -> [Core M.TypeQ] -> DsM (Core M.TypeQ)
repTapps f [] = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
--------- Type constructors --------------
-repNamedTyCon :: Core String -> DsM (Core M.TypQ)
-repNamedTyCon (MkC s) = rep2 conNameTypName [s]
+repNamedTyCon :: Core String -> DsM (Core M.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
-repTupleTyCon :: Int -> DsM (Core M.TypQ)
+repTupleTyCon :: Int -> DsM (Core M.TypeQ)
-- Note: not Core Int; it's easier to be direct here
-repTupleTyCon i = rep2 tupleTypName [mkIntExpr (fromIntegral i)]
+repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
-repArrowTyCon :: DsM (Core M.TypQ)
-repArrowTyCon = rep2 arrowTypName []
+repArrowTyCon :: DsM (Core M.TypeQ)
+repArrowTyCon = rep2 arrowTName []
-repListTyCon :: DsM (Core M.TypQ)
-repListTyCon = rep2 listTypName []
+repListTyCon :: DsM (Core M.TypeQ)
+repListTyCon = rep2 listTName []
----------------------------------------------------------
rep2 lit_name [lit_expr]
where
lit_name = case lit of
- HsInteger _ -> integerLitName
- HsInt _ -> integerLitName
- HsIntPrim _ -> intPrimLitName
- HsFloatPrim _ -> floatPrimLitName
- HsDoublePrim _ -> doublePrimLitName
- HsChar _ -> charLitName
- HsString _ -> stringLitName
- HsRat _ _ -> rationalLitName
+ 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)
templateHaskellNames = mkNameSet [
returnQName, bindQName, sequenceQName, gensymName, liftName,
-- Lit
- charLitName, stringLitName, integerLitName, intPrimLitName,
- floatPrimLitName, doublePrimLitName, rationalLitName,
+ charLName, stringLName, integerLName, intPrimLName,
+ floatPrimLName, doublePrimLName, rationalLName,
-- Pat
- litPatName, varPatName, tupPatName, conPatName, tildePatName,
- asPatName, wildPatName, recPatName,
+ litPName, varPName, tupPName, conPName, tildePName,
+ asPName, wildPName, recPName,
-- FieldPat
fieldPatName,
-- Match
-- Clause
clauseName,
-- Exp
- varExpName, conExpName, litExpName, appExpName, infixExpName,
- infixAppName, sectionLName, sectionRName, lamExpName, tupExpName,
- condExpName, letExpName, caseExpName, doExpName, compExpName,
- fromExpName, fromThenExpName, fromToExpName, fromThenToExpName,
- listExpName, sigExpName, recConExpName, recUpdExpName,
+ varEName, conEName, litEName, appEName, infixEName,
+ infixAppName, sectionLName, sectionRName, lamEName, tupEName,
+ condEName, letEName, caseEName, doEName, compEName,
+ fromEName, fromThenEName, fromToEName, fromThenToEName,
+ listEName, sigEName, recConEName, recUpdEName,
-- FieldExp
fieldExpName,
- -- RHS
- guardedRHSName, normalRHSName,
+ -- Body
+ guardedBName, normalBName,
-- Stmt
- bindStmtName, letStmtName, noBindStmtName, parStmtName,
+ bindSName, letSName, noBindSName, parSName,
-- Dec
- funDecName, valDecName, dataDecName, newtypeDecName, tySynDecName,
- classDecName, instanceDecName, sigDecName,
+ funDName, valDName, dataDName, newtypeDName, tySynDName,
+ classDName, instanceDName, sigDName,
-- Cxt
cxtName,
-- Strict
isStrictName, notStrictName,
-- Con
- normalConName, recConName, infixConName,
- -- StrictTyp
- strictTypName,
- -- VarStrictTyp
- varStrictTypName,
- -- Typ
- forallTypName, varTypName, conTypName, appTypName,
- tupleTypName, arrowTypName, listTypName, conNameTypName,
+ normalCName, recCName, infixCName,
+ -- StrictType
+ strictTypeName,
+ -- VarStrictType
+ varStrictTypeName,
+ -- Type
+ forallTName, varTName, conTName, appTName,
+ tupleTName, arrowTName, listTName,
-- And the tycons
qTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
- decQTyConName, conQTyConName, strictTypQTyConName,
- varStrictTypQTyConName, typQTyConName, expTyConName, decTyConName,
- typTyConName, matchTyConName, clauseTyConName]
+ decQTyConName, conQTyConName, strictTypeQTyConName,
+ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+ typeTyConName, matchTyConName, clauseTyConName]
varQual = mk_known_key_name OccName.varName
tcQual = mk_known_key_name OccName.tcName
liftName = varQual FSLIT("lift") liftIdKey
-- data Lit = ...
-charLitName = varQual FSLIT("charLit") charLitIdKey
-stringLitName = varQual FSLIT("stringLit") stringLitIdKey
-integerLitName = varQual FSLIT("integerLit") integerLitIdKey
-intPrimLitName = varQual FSLIT("intPrimLit") intPrimLitIdKey
-floatPrimLitName = varQual FSLIT("floatPrimLit") floatPrimLitIdKey
-doublePrimLitName = varQual FSLIT("doublePrimLit") doublePrimLitIdKey
-rationalLitName = varQual FSLIT("rationalLit") rationalLitIdKey
+charLName = varQual FSLIT("charL") charLIdKey
+stringLName = varQual FSLIT("stringL") stringLIdKey
+integerLName = varQual FSLIT("integerL") integerLIdKey
+intPrimLName = varQual FSLIT("intPrimL") intPrimLIdKey
+floatPrimLName = varQual FSLIT("floatPrimL") floatPrimLIdKey
+doublePrimLName = varQual FSLIT("doublePrimL") doublePrimLIdKey
+rationalLName = varQual FSLIT("rationalL") rationalLIdKey
-- data Pat = ...
-litPatName = varQual FSLIT("litPat") litPatIdKey
-varPatName = varQual FSLIT("varPat") varPatIdKey
-tupPatName = varQual FSLIT("tupPat") tupPatIdKey
-conPatName = varQual FSLIT("conPat") conPatIdKey
-tildePatName = varQual FSLIT("tildePat") tildePatIdKey
-asPatName = varQual FSLIT("asPat") asPatIdKey
-wildPatName = varQual FSLIT("wildPat") wildPatIdKey
-recPatName = varQual FSLIT("recPat") recPatIdKey
+litPName = varQual FSLIT("litP") litPIdKey
+varPName = varQual FSLIT("varP") varPIdKey
+tupPName = varQual FSLIT("tupP") tupPIdKey
+conPName = varQual FSLIT("conP") conPIdKey
+tildePName = varQual FSLIT("tildeP") tildePIdKey
+asPName = varQual FSLIT("asP") asPIdKey
+wildPName = varQual FSLIT("wildP") wildPIdKey
+recPName = varQual FSLIT("recP") recPIdKey
-- type FieldPat = ...
fieldPatName = varQual FSLIT("fieldPat") fieldPatIdKey
clauseName = varQual FSLIT("clause") clauseIdKey
-- data Exp = ...
-varExpName = varQual FSLIT("varExp") varExpIdKey
-conExpName = varQual FSLIT("conExp") conExpIdKey
-litExpName = varQual FSLIT("litExp") litExpIdKey
-appExpName = varQual FSLIT("appExp") appExpIdKey
-infixExpName = varQual FSLIT("infixExp") infixExpIdKey
-infixAppName = varQual FSLIT("infixApp") infixAppIdKey
-sectionLName = varQual FSLIT("sectionL") sectionLIdKey
-sectionRName = varQual FSLIT("sectionR") sectionRIdKey
-lamExpName = varQual FSLIT("lamExp") lamExpIdKey
-tupExpName = varQual FSLIT("tupExp") tupExpIdKey
-condExpName = varQual FSLIT("condExp") condExpIdKey
-letExpName = varQual FSLIT("letExp") letExpIdKey
-caseExpName = varQual FSLIT("caseExp") caseExpIdKey
-doExpName = varQual FSLIT("doExp") doExpIdKey
-compExpName = varQual FSLIT("compExp") compExpIdKey
+varEName = varQual FSLIT("varE") varEIdKey
+conEName = varQual FSLIT("conE") conEIdKey
+litEName = varQual FSLIT("litE") litEIdKey
+appEName = varQual FSLIT("appE") appEIdKey
+infixEName = varQual FSLIT("infixE") infixEIdKey
+infixAppName = varQual FSLIT("infixApp") infixAppIdKey
+sectionLName = varQual FSLIT("sectionL") sectionLIdKey
+sectionRName = varQual FSLIT("sectionR") sectionRIdKey
+lamEName = varQual FSLIT("lamE") lamEIdKey
+tupEName = varQual FSLIT("tupE") tupEIdKey
+condEName = varQual FSLIT("condE") condEIdKey
+letEName = varQual FSLIT("letE") letEIdKey
+caseEName = varQual FSLIT("caseE") caseEIdKey
+doEName = varQual FSLIT("doE") doEIdKey
+compEName = varQual FSLIT("compE") compEIdKey
-- ArithSeq skips a level
-fromExpName = varQual FSLIT("fromExp") fromExpIdKey
-fromThenExpName = varQual FSLIT("fromThenExp") fromThenExpIdKey
-fromToExpName = varQual FSLIT("fromToExp") fromToExpIdKey
-fromThenToExpName = varQual FSLIT("fromThenToExp") fromThenToExpIdKey
+fromEName = varQual FSLIT("fromE") fromEIdKey
+fromThenEName = varQual FSLIT("fromThenE") fromThenEIdKey
+fromToEName = varQual FSLIT("fromToE") fromToEIdKey
+fromThenToEName = varQual FSLIT("fromThenToE") fromThenToEIdKey
-- end ArithSeq
-listExpName = varQual FSLIT("listExp") listExpIdKey
-sigExpName = varQual FSLIT("sigExp") sigExpIdKey
-recConExpName = varQual FSLIT("recConExp") recConExpIdKey
-recUpdExpName = varQual FSLIT("recUpdExp") recUpdExpIdKey
+listEName = varQual FSLIT("listE") listEIdKey
+sigEName = varQual FSLIT("sigE") sigEIdKey
+recConEName = varQual FSLIT("recConE") recConEIdKey
+recUpdEName = varQual FSLIT("recUpdE") recUpdEIdKey
-- type FieldExp = ...
fieldExpName = varQual FSLIT("fieldExp") fieldExpIdKey
--- data RHS = ...
-guardedRHSName = varQual FSLIT("guardedRHS") guardedRHSIdKey
-normalRHSName = varQual FSLIT("normalRHS") normalRHSIdKey
+-- data Body = ...
+guardedBName = varQual FSLIT("guardedB") guardedBIdKey
+normalBName = varQual FSLIT("normalB") normalBIdKey
-- data Stmt = ...
-bindStmtName = varQual FSLIT("bindStmt") bindStmtIdKey
-letStmtName = varQual FSLIT("letStmt") letStmtIdKey
-noBindStmtName = varQual FSLIT("noBindStmt") noBindStmtIdKey
-parStmtName = varQual FSLIT("parStmt") parStmtIdKey
+bindSName = varQual FSLIT("bindS") bindSIdKey
+letSName = varQual FSLIT("letS") letSIdKey
+noBindSName = varQual FSLIT("noBindS") noBindSIdKey
+parSName = varQual FSLIT("parS") parSIdKey
-- data Dec = ...
-funDecName = varQual FSLIT("funDec") funDecIdKey
-valDecName = varQual FSLIT("valDec") valDecIdKey
-dataDecName = varQual FSLIT("dataDec") dataDecIdKey
-newtypeDecName = varQual FSLIT("newtypeDec") newtypeDecIdKey
-tySynDecName = varQual FSLIT("tySynDec") tySynDecIdKey
-classDecName = varQual FSLIT("classDec") classDecIdKey
-instanceDecName = varQual FSLIT("instanceDec") instanceDecIdKey
-sigDecName = varQual FSLIT("sigDec") sigDecIdKey
+funDName = varQual FSLIT("funD") funDIdKey
+valDName = varQual FSLIT("valD") valDIdKey
+dataDName = varQual FSLIT("dataD") dataDIdKey
+newtypeDName = varQual FSLIT("newtypeD") newtypeDIdKey
+tySynDName = varQual FSLIT("tySynD") tySynDIdKey
+classDName = varQual FSLIT("classD") classDIdKey
+instanceDName = varQual FSLIT("instanceD") instanceDIdKey
+sigDName = varQual FSLIT("sigD") sigDIdKey
-- type Ctxt = ...
cxtName = varQual FSLIT("cxt") cxtIdKey
notStrictName = varQual FSLIT("notStrict") notStrictKey
-- data Con = ...
-normalConName = varQual FSLIT("normalCon") normalConIdKey
-recConName = varQual FSLIT("recCon") recConIdKey
-infixConName = varQual FSLIT("infixCon") infixConIdKey
+normalCName = varQual FSLIT("normalC") normalCIdKey
+recCName = varQual FSLIT("recC") recCIdKey
+infixCName = varQual FSLIT("infixC") infixCIdKey
--- type StrictTyp = ...
-strictTypName = varQual FSLIT("strictTyp") strictTypKey
-
--- type VarStrictTyp = ...
-varStrictTypName = varQual FSLIT("varStrictTyp") varStrictTypKey
-
--- data Typ = ...
-forallTypName = varQual FSLIT("forallTyp") forallTypIdKey
-varTypName = varQual FSLIT("varTyp") varTypIdKey
-conTypName = varQual FSLIT("conTyp") conTypIdKey
-appTypName = varQual FSLIT("appTyp") appTypIdKey
--- Really Tags:
-tupleTypName = varQual FSLIT("tupleTyp") tupleTypIdKey
-arrowTypName = varQual FSLIT("arrowTyp") arrowTypIdKey
-listTypName = varQual FSLIT("listTyp") listTypIdKey
-conNameTypName = varQual FSLIT("conNameTyp") conNameTypIdKey
+-- type StrictType = ...
+strictTypeName = varQual FSLIT("strictType") strictTKey
+
+-- type VarStrictType = ...
+varStrictTypeName = varQual FSLIT("varStrictType") varStrictTKey
+
+-- data Type = ...
+forallTName = varQual FSLIT("forallT") forallTIdKey
+varTName = varQual FSLIT("varT") varTIdKey
+conTName = varQual FSLIT("conT") conTIdKey
+tupleTName = varQual FSLIT("tupleT") tupleTIdKey
+arrowTName = varQual FSLIT("arrowT") arrowTIdKey
+listTName = varQual FSLIT("listT") listTIdKey
+appTName = varQual FSLIT("appT") appTIdKey
-qTyConName = tcQual FSLIT("Q") qTyConKey
-patTyConName = tcQual FSLIT("Pat") patTyConKey
-fieldPatTyConName = tcQual FSLIT("FieldPat") fieldPatTyConKey
-matchQTyConName = tcQual FSLIT("MatchQ") matchQTyConKey
-clauseQTyConName = tcQual FSLIT("ClauseQ") clauseQTyConKey
-expQTyConName = tcQual FSLIT("ExpQ") expQTyConKey
-fieldExpTyConName = tcQual FSLIT("FieldExp") fieldExpTyConKey
-stmtQTyConName = tcQual FSLIT("StmtQ") stmtQTyConKey
-decQTyConName = tcQual FSLIT("DecQ") decQTyConKey
-conQTyConName = tcQual FSLIT("ConQ") conQTyConKey
-strictTypQTyConName = tcQual FSLIT("StrictTypQ") strictTypQTyConKey
-varStrictTypQTyConName = tcQual FSLIT("VarStrictTypQ") varStrictTypQTyConKey
-typQTyConName = tcQual FSLIT("TypQ") typQTyConKey
+qTyConName = tcQual FSLIT("Q") qTyConKey
+patTyConName = tcQual FSLIT("Pat") patTyConKey
+fieldPatTyConName = tcQual FSLIT("FieldPat") fieldPatTyConKey
+matchQTyConName = tcQual FSLIT("MatchQ") matchQTyConKey
+clauseQTyConName = tcQual FSLIT("ClauseQ") clauseQTyConKey
+expQTyConName = tcQual FSLIT("ExpQ") expQTyConKey
+fieldExpTyConName = tcQual FSLIT("FieldExp") fieldExpTyConKey
+stmtQTyConName = tcQual FSLIT("StmtQ") stmtQTyConKey
+decQTyConName = tcQual FSLIT("DecQ") decQTyConKey
+conQTyConName = tcQual FSLIT("ConQ") conQTyConKey
+strictTypeQTyConName = tcQual FSLIT("StrictTypeQ") strictTypeQTyConKey
+varStrictTypeQTyConName = tcQual FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
+typeQTyConName = tcQual FSLIT("TypeQ") typeQTyConKey
expTyConName = tcQual FSLIT("Exp") expTyConKey
decTyConName = tcQual FSLIT("Dec") decTyConKey
-typTyConName = tcQual FSLIT("Typ") typTyConKey
+typeTyConName = tcQual FSLIT("Type") typeTyConKey
matchTyConName = tcQual FSLIT("Match") matchTyConKey
clauseTyConName = tcQual FSLIT("Clause") clauseTyConKey
clauseQTyConKey = mkPreludeTyConUnique 108
stmtQTyConKey = mkPreludeTyConUnique 109
conQTyConKey = mkPreludeTyConUnique 110
-typQTyConKey = mkPreludeTyConUnique 111
-typTyConKey = mkPreludeTyConUnique 112
+typeQTyConKey = mkPreludeTyConUnique 111
+typeTyConKey = mkPreludeTyConUnique 112
decTyConKey = mkPreludeTyConUnique 113
-varStrictTypQTyConKey = mkPreludeTyConUnique 114
-strictTypQTyConKey = mkPreludeTyConUnique 115
+varStrictTypeQTyConKey = mkPreludeTyConUnique 114
+strictTypeQTyConKey = mkPreludeTyConUnique 115
fieldExpTyConKey = mkPreludeTyConUnique 116
fieldPatTyConKey = mkPreludeTyConUnique 117
liftIdKey = mkPreludeMiscIdUnique 204
-- data Lit = ...
-charLitIdKey = mkPreludeMiscIdUnique 210
-stringLitIdKey = mkPreludeMiscIdUnique 211
-integerLitIdKey = mkPreludeMiscIdUnique 212
-intPrimLitIdKey = mkPreludeMiscIdUnique 213
-floatPrimLitIdKey = mkPreludeMiscIdUnique 214
-doublePrimLitIdKey = mkPreludeMiscIdUnique 215
-rationalLitIdKey = mkPreludeMiscIdUnique 216
+charLIdKey = mkPreludeMiscIdUnique 210
+stringLIdKey = mkPreludeMiscIdUnique 211
+integerLIdKey = mkPreludeMiscIdUnique 212
+intPrimLIdKey = mkPreludeMiscIdUnique 213
+floatPrimLIdKey = mkPreludeMiscIdUnique 214
+doublePrimLIdKey = mkPreludeMiscIdUnique 215
+rationalLIdKey = mkPreludeMiscIdUnique 216
-- data Pat = ...
-litPatIdKey = mkPreludeMiscIdUnique 220
-varPatIdKey = mkPreludeMiscIdUnique 221
-tupPatIdKey = mkPreludeMiscIdUnique 222
-conPatIdKey = mkPreludeMiscIdUnique 223
-tildePatIdKey = mkPreludeMiscIdUnique 224
-asPatIdKey = mkPreludeMiscIdUnique 225
-wildPatIdKey = mkPreludeMiscIdUnique 226
-recPatIdKey = mkPreludeMiscIdUnique 227
+litPIdKey = mkPreludeMiscIdUnique 220
+varPIdKey = mkPreludeMiscIdUnique 221
+tupPIdKey = mkPreludeMiscIdUnique 222
+conPIdKey = mkPreludeMiscIdUnique 223
+tildePIdKey = mkPreludeMiscIdUnique 224
+asPIdKey = mkPreludeMiscIdUnique 225
+wildPIdKey = mkPreludeMiscIdUnique 226
+recPIdKey = mkPreludeMiscIdUnique 227
-- type FieldPat = ...
fieldPatIdKey = mkPreludeMiscIdUnique 228
clauseIdKey = mkPreludeMiscIdUnique 230
-- data Exp = ...
-varExpIdKey = mkPreludeMiscIdUnique 240
-conExpIdKey = mkPreludeMiscIdUnique 241
-litExpIdKey = mkPreludeMiscIdUnique 242
-appExpIdKey = mkPreludeMiscIdUnique 243
-infixExpIdKey = mkPreludeMiscIdUnique 244
+varEIdKey = mkPreludeMiscIdUnique 240
+conEIdKey = mkPreludeMiscIdUnique 241
+litEIdKey = mkPreludeMiscIdUnique 242
+appEIdKey = mkPreludeMiscIdUnique 243
+infixEIdKey = mkPreludeMiscIdUnique 244
infixAppIdKey = mkPreludeMiscIdUnique 245
sectionLIdKey = mkPreludeMiscIdUnique 246
sectionRIdKey = mkPreludeMiscIdUnique 247
-lamExpIdKey = mkPreludeMiscIdUnique 248
-tupExpIdKey = mkPreludeMiscIdUnique 249
-condExpIdKey = mkPreludeMiscIdUnique 250
-letExpIdKey = mkPreludeMiscIdUnique 251
-caseExpIdKey = mkPreludeMiscIdUnique 252
-doExpIdKey = mkPreludeMiscIdUnique 253
-compExpIdKey = mkPreludeMiscIdUnique 254
-fromExpIdKey = mkPreludeMiscIdUnique 255
-fromThenExpIdKey = mkPreludeMiscIdUnique 256
-fromToExpIdKey = mkPreludeMiscIdUnique 257
-fromThenToExpIdKey = mkPreludeMiscIdUnique 258
-listExpIdKey = mkPreludeMiscIdUnique 259
-sigExpIdKey = mkPreludeMiscIdUnique 260
-recConExpIdKey = mkPreludeMiscIdUnique 261
-recUpdExpIdKey = mkPreludeMiscIdUnique 262
+lamEIdKey = mkPreludeMiscIdUnique 248
+tupEIdKey = mkPreludeMiscIdUnique 249
+condEIdKey = mkPreludeMiscIdUnique 250
+letEIdKey = mkPreludeMiscIdUnique 251
+caseEIdKey = mkPreludeMiscIdUnique 252
+doEIdKey = mkPreludeMiscIdUnique 253
+compEIdKey = mkPreludeMiscIdUnique 254
+fromEIdKey = mkPreludeMiscIdUnique 255
+fromThenEIdKey = mkPreludeMiscIdUnique 256
+fromToEIdKey = mkPreludeMiscIdUnique 257
+fromThenToEIdKey = mkPreludeMiscIdUnique 258
+listEIdKey = mkPreludeMiscIdUnique 259
+sigEIdKey = mkPreludeMiscIdUnique 260
+recConEIdKey = mkPreludeMiscIdUnique 261
+recUpdEIdKey = mkPreludeMiscIdUnique 262
-- type FieldExp = ...
fieldExpIdKey = mkPreludeMiscIdUnique 265
--- data RHS = ...
-guardedRHSIdKey = mkPreludeMiscIdUnique 266
-normalRHSIdKey = mkPreludeMiscIdUnique 267
+-- data Body = ...
+guardedBIdKey = mkPreludeMiscIdUnique 266
+normalBIdKey = mkPreludeMiscIdUnique 267
-- data Stmt = ...
-bindStmtIdKey = mkPreludeMiscIdUnique 268
-letStmtIdKey = mkPreludeMiscIdUnique 269
-noBindStmtIdKey = mkPreludeMiscIdUnique 270
-parStmtIdKey = mkPreludeMiscIdUnique 271
+bindSIdKey = mkPreludeMiscIdUnique 268
+letSIdKey = mkPreludeMiscIdUnique 269
+noBindSIdKey = mkPreludeMiscIdUnique 270
+parSIdKey = mkPreludeMiscIdUnique 271
-- data Dec = ...
-funDecIdKey = mkPreludeMiscIdUnique 272
-valDecIdKey = mkPreludeMiscIdUnique 273
-dataDecIdKey = mkPreludeMiscIdUnique 274
-newtypeDecIdKey = mkPreludeMiscIdUnique 275
-tySynDecIdKey = mkPreludeMiscIdUnique 276
-classDecIdKey = mkPreludeMiscIdUnique 277
-instanceDecIdKey = mkPreludeMiscIdUnique 278
-sigDecIdKey = mkPreludeMiscIdUnique 279
+funDIdKey = mkPreludeMiscIdUnique 272
+valDIdKey = mkPreludeMiscIdUnique 273
+dataDIdKey = mkPreludeMiscIdUnique 274
+newtypeDIdKey = mkPreludeMiscIdUnique 275
+tySynDIdKey = mkPreludeMiscIdUnique 276
+classDIdKey = mkPreludeMiscIdUnique 277
+instanceDIdKey = mkPreludeMiscIdUnique 278
+sigDIdKey = mkPreludeMiscIdUnique 279
-- type Cxt = ...
cxtIdKey = mkPreludeMiscIdUnique 280
notStrictKey = mkPreludeMiscIdUnique 282
-- data Con = ...
-normalConIdKey = mkPreludeMiscIdUnique 283
-recConIdKey = mkPreludeMiscIdUnique 284
-infixConIdKey = mkPreludeMiscIdUnique 285
-
--- type StrictTyp = ...
-strictTypKey = mkPreludeMiscIdUnique 2286
-
--- type VarStrictTyp = ...
-varStrictTypKey = mkPreludeMiscIdUnique 287
-
--- data Typ = ...
-forallTypIdKey = mkPreludeMiscIdUnique 290
-varTypIdKey = mkPreludeMiscIdUnique 291
-conTypIdKey = mkPreludeMiscIdUnique 292
-appTypIdKey = mkPreludeMiscIdUnique 293
--- Really Tags:
-tupleTypIdKey = mkPreludeMiscIdUnique 294
-arrowTypIdKey = mkPreludeMiscIdUnique 295
-listTypIdKey = mkPreludeMiscIdUnique 296
-conNameTypIdKey = mkPreludeMiscIdUnique 297
+normalCIdKey = mkPreludeMiscIdUnique 283
+recCIdKey = mkPreludeMiscIdUnique 284
+infixCIdKey = mkPreludeMiscIdUnique 285
+
+-- type StrictType = ...
+strictTKey = mkPreludeMiscIdUnique 2286
+
+-- type VarStrictType = ...
+varStrictTKey = mkPreludeMiscIdUnique 287
+
+-- data Type = ...
+forallTIdKey = mkPreludeMiscIdUnique 290
+varTIdKey = mkPreludeMiscIdUnique 291
+conTIdKey = mkPreludeMiscIdUnique 292
+tupleTIdKey = mkPreludeMiscIdUnique 294
+arrowTIdKey = mkPreludeMiscIdUnique 295
+listTIdKey = mkPreludeMiscIdUnique 296
+appTIdKey = mkPreludeMiscIdUnique 293
-- %************************************************************************
-- %* *
convertToHsDecls ds = map cvt_top ds
mk_con con = case con of
- NormalCon c strtys
+ NormalC c strtys
-> ConDecl (cName c) noExistentials noContext
(PrefixCon (map mk_arg strtys)) loc0
- Meta.RecCon c varstrtys
+ RecC c varstrtys
-> ConDecl (cName c) noExistentials noContext
- (Hs.RecCon (map mk_id_arg varstrtys)) loc0
- Meta.InfixCon st1 c st2
+ (RecCon (map mk_id_arg varstrtys)) loc0
+ InfixC st1 c st2
-> ConDecl (cName c) noExistentials noContext
- (Hs.InfixCon (mk_arg st1) (mk_arg st2)) loc0
+ (InfixCon (mk_arg st1) (mk_arg st2)) loc0
where
mk_arg (IsStrict, ty) = BangType MarkedUserStrict (cvtType ty)
mk_arg (NotStrict, ty) = BangType NotMarkedStrict (cvtType ty)
mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
-cvt_top d@(ValDec _ _ _) = Left $ ValD (cvtd d)
-cvt_top d@(FunDec _ _) = Left $ ValD (cvtd d)
+cvt_top d@(Meta.ValD _ _ _) = Left $ Hs.ValD (cvtd d)
+cvt_top d@(Meta.FunD _ _) = Left $ Hs.ValD (cvtd d)
-cvt_top (TySynDec tc tvs rhs)
+cvt_top (TySynD tc tvs rhs)
= Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)
-cvt_top (DataDec ctxt tc tvs constrs derivs)
+cvt_top (DataD ctxt tc tvs constrs derivs)
= Left $ TyClD (mkTyData DataType
(cvt_context ctxt, tconName tc, cvt_tvs tvs)
(DataCons (map mk_con constrs))
(mk_derivs derivs) loc0)
-cvt_top (NewtypeDec ctxt tc tvs constr derivs)
+cvt_top (NewtypeD ctxt tc tvs constr derivs)
= Left $ TyClD (mkTyData NewType
(cvt_context ctxt, tconName tc, cvt_tvs tvs)
(DataCons [mk_con constr])
(mk_derivs derivs) loc0)
-cvt_top (ClassDec ctxt cl tvs decs)
+cvt_top (ClassD ctxt cl tvs decs)
= Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
noFunDeps sigs
(Just binds) loc0)
where
(binds,sigs) = cvtBindsAndSigs decs
-cvt_top (InstanceDec tys ty decs)
+cvt_top (InstanceD tys ty decs)
= Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0)
where
(binds, sigs) = cvtBindsAndSigs decs
(cvt_context tys)
(HsPredTy (cvt_pred ty))
-cvt_top (SigDec nm typ) = Left $ SigD (Sig (vName nm) (cvtType typ) loc0)
+cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0)
-cvt_top (ForeignDec (ImportForeign callconv safety from nm typ))
+cvt_top (ForeignD (ImportF callconv safety from nm typ))
= case parsed of
Just (c_header, cis) ->
let i = CImport callconv' safety' c_header nilFS cis
convertToHsExpr :: Meta.Exp -> HsExpr RdrName
convertToHsExpr = cvt
-cvt (VarExp s) = HsVar (vName s)
-cvt (ConExp s) = HsVar (cName s)
-cvt (LitExp l)
+cvt (VarE s) = HsVar (vName s)
+cvt (ConE s) = HsVar (cName s)
+cvt (LitE l)
| overloadedLit l = HsOverLit (cvtOverLit l)
| otherwise = HsLit (cvtLit l)
-cvt (AppExp x y) = HsApp (cvt x) (cvt y)
-cvt (LamExp ps e) = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
-cvt (TupExp [e]) = cvt e
-cvt (TupExp es) = ExplicitTuple(map cvt es) Boxed
-cvt (CondExp x y z) = HsIf (cvt x) (cvt y) (cvt z) loc0
-cvt (LetExp ds e) = HsLet (cvtdecs ds) (cvt e)
-cvt (CaseExp e ms) = HsCase (cvt e) (map cvtm ms) loc0
-cvt (DoExp ss) = HsDo DoExpr (cvtstmts ss) [] void loc0
-cvt (CompExp ss) = HsDo ListComp (cvtstmts ss) [] void loc0
-cvt (ArithSeqExp dd) = ArithSeqIn (cvtdd dd)
-cvt (ListExp xs) = ExplicitList void (map cvt xs)
-cvt (InfixExp (Just x) s (Just y))
+cvt (AppE x y) = HsApp (cvt x) (cvt y)
+cvt (LamE ps e) = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
+cvt (TupE [e]) = cvt e
+cvt (TupE es) = ExplicitTuple(map cvt es) Boxed
+cvt (CondE x y z) = HsIf (cvt x) (cvt y) (cvt z) loc0
+cvt (LetE ds e) = HsLet (cvtdecs ds) (cvt e)
+cvt (CaseE e ms) = HsCase (cvt e) (map cvtm ms) loc0
+cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void loc0
+cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void loc0
+cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
+cvt (ListE xs) = ExplicitList void (map cvt xs)
+cvt (InfixE (Just x) s (Just y))
= HsPar (OpApp (cvt x) (cvt s) undefined (cvt y))
-cvt (InfixExp Nothing s (Just y)) = SectionR (cvt s) (cvt y)
-cvt (InfixExp (Just x) s Nothing ) = SectionL (cvt x) (cvt s)
-cvt (InfixExp Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
-cvt (SigExp e t) = ExprWithTySig (cvt e) (cvtType t)
-cvt (RecConExp c flds) = RecordCon (cName c) (map (\(x,y) -> (vName x, cvt y)) flds)
-cvt (RecUpdExp e flds) = RecordUpd (cvt e) (map (\(x,y) -> (vName x, cvt y)) flds)
+cvt (InfixE Nothing s (Just y)) = SectionR (cvt s) (cvt y)
+cvt (InfixE (Just x) s Nothing ) = SectionL (cvt x) (cvt s)
+cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
+cvt (SigE e t) = ExprWithTySig (cvt e) (cvtType t)
+cvt (RecConE c flds) = RecordCon (cName c) (map (\(x,y) -> (vName x, cvt y)) flds)
+cvt (RecUpdE e flds) = RecordUpd (cvt e) (map (\(x,y) -> (vName x, cvt y)) flds)
cvtdecs :: [Meta.Dec] -> HsBinds RdrName
cvtdecs [] = EmptyBinds
where
(sigs, non_sigs) = partition sigP ds
-cvtSig (SigDec nm typ) = Sig (vName nm) (cvtType typ) loc0
+cvtSig (Meta.SigD nm typ) = Hs.Sig (vName nm) (cvtType typ) loc0
cvtds :: [Meta.Dec] -> MonoBinds RdrName
cvtds [] = EmptyMonoBinds
cvtd :: Meta.Dec -> MonoBinds RdrName
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
-cvtd (ValDec (Meta.VarPat s) body ds) = FunMonoBind (vName s) False
+cvtd (Meta.ValD (Meta.VarP s) body ds) = FunMonoBind (vName s) False
[cvtclause (Clause [] body ds)] loc0
-cvtd (FunDec nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0
-cvtd (ValDec p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body)
+cvtd (FunD nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0
+cvtd (Meta.ValD p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body)
(cvtdecs ds)
void) loc0
cvtd x = panic "Illegal kind of declaration in where clause"
-cvtdd :: Meta.DotDot -> ArithSeqInfo RdrName
-cvtdd (FromDotDot x) = (Hs.From (cvt x))
-cvtdd (FromThenDotDot x y) = (Hs.FromThen (cvt x) (cvt y))
-cvtdd (FromToDotDot x y) = (Hs.FromTo (cvt x) (cvt y))
-cvtdd (FromThenToDotDot x y z) = (Hs.FromThenTo (cvt x) (cvt y) (cvt z))
+cvtdd :: Range -> ArithSeqInfo RdrName
+cvtdd (FromR x) = (From (cvt x))
+cvtdd (FromThenR x y) = (FromThen (cvt x) (cvt y))
+cvtdd (FromToR x y) = (FromTo (cvt x) (cvt y))
+cvtdd (FromThenToR x y z) = (FromThenTo (cvt x) (cvt y) (cvt z))
cvtstmts :: [Meta.Stmt] -> [Hs.Stmt RdrName]
cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
-cvtstmts [NoBindStmt e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
-cvtstmts (NoBindStmt e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
-cvtstmts (Meta.BindStmt p e : ss) = Hs.BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
-cvtstmts (Meta.LetStmt ds : ss) = Hs.LetStmt (cvtdecs ds) : cvtstmts ss
-cvtstmts (Meta.ParStmt dss : ss) = Hs.ParStmt(map cvtstmts dss) : cvtstmts ss
+cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
+cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
+cvtstmts (Meta.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
+cvtstmts (Meta.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
+cvtstmts (Meta.ParS dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss
cvtm :: Meta.Match -> Hs.Match RdrName
cvtm (Meta.Match p body wheres)
= Hs.Match [cvtp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
-cvtguard :: Meta.RHS -> [GRHS RdrName]
-cvtguard (GuardedRHS pairs) = map cvtpair pairs
-cvtguard (NormalRHS e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0]
+cvtguard :: Meta.Body -> [GRHS RdrName]
+cvtguard (GuardedB pairs) = map cvtpair pairs
+cvtguard (NormalB e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0]
cvtpair :: (Meta.Exp,Meta.Exp) -> GRHS RdrName
cvtpair (x,y) = GRHS [Hs.BindStmt truePat (cvt x) loc0,
ResultStmt (cvt y) loc0] loc0
cvtOverLit :: Lit -> HsOverLit
-cvtOverLit (IntegerLit i) = mkHsIntegral i
-cvtOverLit (RationalLit r) = mkHsFractional r
+cvtOverLit (IntegerL i) = mkHsIntegral i
+cvtOverLit (RationalL r) = mkHsFractional r
-- An Integer is like an an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
cvtLit :: Lit -> HsLit
-cvtLit (IntPrimLit i) = HsIntPrim i
-cvtLit (FloatPrimLit f) = HsFloatPrim f
-cvtLit (DoublePrimLit f) = HsDoublePrim f
-cvtLit (CharLit c) = HsChar (ord c)
-cvtLit (StringLit s) = HsString (mkFastString s)
+cvtLit (IntPrimL i) = HsIntPrim i
+cvtLit (FloatPrimL f) = HsFloatPrim f
+cvtLit (DoublePrimL f) = HsDoublePrim f
+cvtLit (CharL c) = HsChar (ord c)
+cvtLit (StringL s) = HsString (mkFastString s)
cvtp :: Meta.Pat -> Hs.Pat RdrName
-cvtp (Meta.LitPat l)
+cvtp (Meta.LitP l)
| overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
-- patterns; need to think
-- about that!
| otherwise = Hs.LitPat (cvtLit l)
-cvtp (Meta.VarPat s) = Hs.VarPat(vName s)
-cvtp (TupPat [p]) = cvtp p
-cvtp (TupPat ps) = TuplePat (map cvtp ps) Boxed
-cvtp (ConPat s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps))
-cvtp (TildePat p) = LazyPat (cvtp p)
-cvtp (Meta.AsPat s p) = Hs.AsPat (vName s) (cvtp p)
-cvtp Meta.WildPat = Hs.WildPat void
-cvtp (RecPat c fs) = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs)
+cvtp (Meta.VarP s) = Hs.VarPat(vName s)
+cvtp (TupP [p]) = cvtp p
+cvtp (TupP ps) = TuplePat (map cvtp ps) Boxed
+cvtp (ConP s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps))
+cvtp (TildeP p) = LazyPat (cvtp p)
+cvtp (Meta.AsP s p) = AsPat (vName s) (cvtp p)
+cvtp Meta.WildP = WildPat void
+cvtp (RecP c fs) = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs)
-----------------------------------------------------------
-- Types and type variables
cvt_context :: Cxt -> HsContext RdrName
cvt_context tys = map cvt_pred tys
-cvt_pred :: Typ -> HsPred RdrName
+cvt_pred :: Meta.Type -> HsPred RdrName
cvt_pred ty = case split_ty_app ty of
- (ConTyp (ConNameTag tc), tys) -> HsClassP (tconName tc) (map cvtType tys)
+ (ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
other -> panic "Malformed predicate"
-cvtType :: Meta.Typ -> HsType RdrName
+cvtType :: Meta.Type -> HsType RdrName
cvtType ty = trans (root ty [])
- where root (AppTyp a b) zs = root a (cvtType b : zs)
+ where root (AppT a b) zs = root a (cvtType b : zs)
root t zs = (t,zs)
- trans (ConTyp (TupleTag n),args) | length args == n
- = HsTupleTy (HsTupCon Boxed n) args
- trans (ConTyp ArrowTag, [x,y]) = HsFunTy x y
- trans (ConTyp ListTag, [x]) = HsListTy x
+ trans (TupleT n,args)
+ | length args == n = HsTupleTy (HsTupCon Boxed n) args
+ | n == 0 = foldl HsAppTy (HsTyVar (tconName "()")) args
+ | otherwise = foldl HsAppTy (HsTyVar (tconName ("(" ++ replicate (n-1) ',' ++ ")"))) args
+ trans (ArrowT, [x,y]) = HsFunTy x y
+ trans (ListT, [x]) = HsListTy x
- trans (VarTyp nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args
- trans (ConTyp tc, args) = foldl HsAppTy (HsTyVar (tc_name tc)) args
+ trans (VarT nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args
+ trans (ConT tc, args) = foldl HsAppTy (HsTyVar (tconName tc)) args
- trans (ForallTyp tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs))
+ trans (ForallT tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs))
(cvt_context cxt)
(cvtType ty)
- tc_name (ConNameTag nm) = tconName nm
- tc_name ArrowTag = tconName "->"
- tc_name ListTag = tconName "[]"
- tc_name (TupleTag 0) = tconName "()"
- tc_name (TupleTag n) = tconName ("(" ++ replicate (n-1) ',' ++ ")")
-
-split_ty_app :: Typ -> (Typ, [Typ])
+split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type])
split_ty_app ty = go ty []
where
- go (AppTyp f a) as = go f (a:as)
+ go (AppT f a) as = go f (a:as)
go f as = (f,as)
-----------------------------------------------------------
sigP :: Dec -> Bool
-sigP (SigDec _ _) = True
+sigP (Meta.SigD _ _) = True
sigP other = False
overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
-overloadedLit (IntegerLit l) = True
-overloadedLit (RationalLit l) = True
-overloadedLit l = False
+overloadedLit (IntegerL l) = True
+overloadedLit (RationalL l) = True
+overloadedLit l = False
void :: Type.Type
void = placeHolderType
projects / ghc-hetmet.git / commitdiff