From cb51a09231da94d729bcd62177cbdec1a888a180 Mon Sep 17 00:00:00 2001 From: igloo Date: Fri, 6 Jun 2003 16:04:26 +0000 Subject: [PATCH] [project @ 2003-06-06 16:04:23 by igloo] Template Haskell Renamings as described in http://www.haskell.org/pipermail/template-haskell/2003-May/000110.html --- ghc/compiler/deSugar/DsMeta.hs | 546 +++++++++++++++++------------------ ghc/compiler/hsSyn/Convert.lhs | 178 ++++++------ ghc/compiler/typecheck/TcExpr.lhs | 2 +- ghc/compiler/typecheck/TcSplice.lhs | 4 +- 4 files changed, 361 insertions(+), 369 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 72e4654..7cda61d 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -13,8 +13,8 @@ module DsMeta( dsBracket, dsReify, templateHaskellNames, qTyConName, - liftName, expQTyConName, decQTyConName, typQTyConName, - decTyConName, typTyConName ) where + liftName, expQTyConName, decQTyConName, typeQTyConName, + decTyConName, typeTyConName ) where #include "HsVersions.h" @@ -97,7 +97,7 @@ dsBracket brack splices ----------------------------------------------------------------------------- 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) @@ -286,10 +286,10 @@ repC (ConDecl con [] [] details loc) = 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 @@ -362,12 +362,12 @@ addTyVarBinds tvs m = 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 @@ -377,12 +377,12 @@ repPred (HsIParam _ _) = -- 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 @@ -563,7 +563,7 @@ repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = ; 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 @@ -932,28 +932,28 @@ rep2 n xs = do { id <- dsLookupGlobalId n --------------- 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) @@ -961,49 +961,49 @@ repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str | 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] @@ -1015,120 +1015,120 @@ 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.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 [] ---------------------------------------------------------- @@ -1148,14 +1148,14 @@ repLiteral lit 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) @@ -1233,11 +1233,11 @@ templateHaskellNames :: NameSet 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 @@ -1245,40 +1245,40 @@ templateHaskellNames = mkNameSet [ -- 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 @@ -1297,23 +1297,23 @@ gensymName = varQual FSLIT("gensym") gensymIdKey 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 @@ -1325,54 +1325,54 @@ matchName = varQual FSLIT("match") matchIdKey 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 @@ -1382,44 +1382,42 @@ isStrictName = varQual FSLIT("isStrict") isStrictKey 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 @@ -1437,11 +1435,11 @@ matchQTyConKey = mkPreludeTyConUnique 107 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 @@ -1455,23 +1453,23 @@ gensymIdKey = mkPreludeMiscIdUnique 203 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 @@ -1483,52 +1481,52 @@ matchIdKey = mkPreludeMiscIdUnique 229 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 @@ -1538,26 +1536,24 @@ isStrictKey = mkPreludeMiscIdUnique 281 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 -- %************************************************************************ -- %* * diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index a036745..2135d18 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -47,15 +47,15 @@ convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message] 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) @@ -69,32 +69,32 @@ mk_derivs [] = Nothing 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 @@ -102,9 +102,9 @@ cvt_top (InstanceDec tys ty 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 @@ -168,31 +168,31 @@ noFunDeps = [] 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 @@ -205,7 +205,7 @@ cvtBindsAndSigs ds 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 @@ -214,10 +214,10 @@ cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds) 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" @@ -229,61 +229,61 @@ cvtclause (Clause ps body wheres) -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 @@ -294,43 +294,39 @@ cvt_tvs tvs = map (UserTyVar . tName) tvs 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 @@ -342,9 +338,9 @@ falsePat = ConPatIn (cName "False") (PrefixCon []) 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 diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 1ee7af1..f44b757 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -630,7 +630,7 @@ tcMonoExpr (HsReify (Reify flavour name)) res_ty where tycon_name = case flavour of ReifyDecl -> DsMeta.decQTyConName - ReifyType -> DsMeta.typQTyConName + ReifyType -> DsMeta.typeQTyConName ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name) #endif /* GHCI */ \end{code} diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 2723081..a63f6bd 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -34,7 +34,7 @@ import Name ( Name ) import TcRnMonad import TysWiredIn ( mkListTy ) -import DsMeta ( expQTyConName, decQTyConName, typQTyConName, decTyConName, qTyConName ) +import DsMeta ( expQTyConName, decQTyConName, typeQTyConName, decTyConName, qTyConName ) import ErrUtils (Message) import Outputable import Panic ( showException ) @@ -105,7 +105,7 @@ tc_bracket (ExpBr expr) tc_bracket (TypBr typ) = tcHsSigType ExprSigCtxt typ `thenM_` - tcMetaTy typQTyConName + tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) -- 1.7.10.4