import {-# SOURCE #-} DsExpr ( dsExpr )
-import DsUtils ( mkListExpr, mkStringLit, mkCoreTup,
- mkIntExpr, mkCharExpr )
+import MatchLit ( dsLit )
+import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
import DsMonad
import qualified Language.Haskell.THSyntax as M
-- ws previously used in this file.
import qualified OccName( varName, tcName )
-import Module ( moduleUserString )
+import Module ( Module, mkThPkgModule, moduleUserString )
import Id ( Id, idType )
+import Name ( mkKnownKeyExternalName )
+import OccName ( mkOccFS )
import NameEnv
import NameSet
import Type ( Type, TyThing(..), mkGenTyConApp )
import Maybe ( catMaybes )
import Panic ( panic )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
-import BasicTypes ( NewOrData(..), StrictnessMark(..) )
+import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
import Outputable
import FastString ( mkFastString )
repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig
------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- Expressions
------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
repEs es = do { es' <- mapM repE es ;
coreList exprTyConName es' }
+-- FIXME: some of these panics should be converted into proper error messages
+-- unless we can make sure that constructs, which are plainly not
+-- supported in TH already lead to error messages at an earlier stage
repE :: HsExpr Name -> DsM (Core M.Expr)
-repE (HsVar x)
- = do { mb_val <- dsLookupMetaEnv x
- ; case mb_val of
- Nothing -> do { str <- globalVar x
- ; repVarOrCon x str }
- Just (Bound y) -> repVarOrCon x (coreVar y)
- Just (Splice e) -> do { e' <- dsExpr e
- ; return (MkC e') } }
-
-repE (HsIPVar x) = panic "Can't represent implicit parameters"
-repE (HsLit l) = do { a <- repLiteral l; repLit a }
-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-
-repE (HsSplice n e loc)
- = do { mb_val <- dsLookupMetaEnv n
- ; case mb_val of
- Just (Splice e) -> do { e' <- dsExpr e
- ; return (MkC e') }
- other -> pprPanic "HsSplice" (ppr n) }
-
-
-repE (HsLam m) = repLambda m
-repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
-repE (NegApp x nm) = panic "No negate yet"
-repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
-repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
-
-repE (OpApp e1 (HsVar op) fix e2)
- = do { arg1 <- repE e1;
- arg2 <- repE e2;
- the_op <- lookupOcc op ;
- repInfixApp arg1 the_op arg2 }
-
-repE (HsCase e ms loc)
- = do { arg <- repE e
- ; ms2 <- mapM repMatchTup ms
- ; repCaseE arg (nonEmptyCoreList ms2) }
-
--- I havn't got the types here right yet
-repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts;
- e <- repDoE (nonEmptyCoreList zs);
- wrapGenSyns expTyConName ss e }
-repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
- e <- repComp (nonEmptyCoreList zs);
- wrapGenSyns expTyConName ss e }
-
-repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 }
-repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
- repFromThen ds1 ds2 }
-repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
- repFromTo ds1 ds2 }
-repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
- ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
-
-repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
-
-repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
- ; e2 <- addBinds ss (repE e)
- ; z <- repLetE ds e2
- ; wrapGenSyns expTyConName ss z }
-repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
-repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs }
-
-repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
-repE (RecordConOut _ _ _) = panic "No record construction yet"
-repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
-repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
-
+repE (HsVar x) =
+ do { mb_val <- dsLookupMetaEnv x
+ ; case mb_val of
+ Nothing -> do { str <- globalVar x
+ ; repVarOrCon x str }
+ Just (Bound y) -> repVarOrCon x (coreVar y)
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') } }
+repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
+repE (HsLit l) = do { a <- repLiteral l; repLit a }
+repE (HsLam m) = repLambda m
+repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
+-- HsOverLit l never happens (if it does, the catch-all will find it)
+
+repE (OpApp e1 op fix e2) =
+ case op of
+ HsVar op -> do { arg1 <- repE e1;
+ arg2 <- repE e2;
+ the_op <- lookupOcc op ;
+ repInfixApp arg1 the_op arg2 }
+ _ -> panic "DsMeta.repE: Operator is not a variable"
+repE (NegApp x nm) = repE x >>= repNeg
+repE (HsPar x) = repE x
+repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
+repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
+repE (HsCase e ms loc) = do { arg <- repE e
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsIf x y z loc) = do
+ a <- repE x
+ b <- repE y
+ c <- repE z
+ repCond a b c
+repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
+ ; e2 <- addBinds ss (repE e)
+ ; z <- repLetE ds e2
+ ; wrapGenSyns expTyConName ss z }
+-- FIXME: I haven't got the types here right yet
+repE (HsDo ctxt sts _ ty loc)
+ | isComprCtxt ctxt = do { (ss,zs) <- repSts sts;
+ e <- repDoE (nonEmptyCoreList zs);
+ wrapGenSyns expTyConName ss e }
+ | otherwise =
+ panic "DsMeta.repE: Can't represent mdo and [: :] yet"
+ where
+ isComprCtxt ListComp = True
+ isComprCtxt DoExpr = True
+ isComprCtxt _ = False
+repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
+repE (ExplicitPArr ty es) =
+ panic "DsMeta.repE: No explicit parallel arrays yet"
+repE (ExplicitTuple es boxed)
+ | isBoxed boxed = do { xs <- repEs es; repTup xs }
+ | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
+repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
+repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
+
+repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
+repE (ArithSeqOut _ aseq) =
+ case aseq of
+ From e -> do { ds1 <- repE e; repFrom ds1 }
+ FromThen e1 e2 -> do
+ ds1 <- repE e1
+ ds2 <- repE e2
+ repFromThen ds1 ds2
+ FromTo e1 e2 -> do
+ ds1 <- repE e1
+ ds2 <- repE e2
+ repFromTo ds1 ds2
+ FromThenTo e1 e2 e3 -> do
+ ds1 <- repE e1
+ ds2 <- repE e2
+ ds3 <- repE e3
+ repFromThenTo ds1 ds2 ds3
+repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
+repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
+repE (HsBracketOut _ _) =
+ panic "DsMeta.repE: Can't represent Oxford brackets"
+repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
+ ; case mb_val of
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') }
+ other -> pprPanic "HsSplice" (ppr n) }
+repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
+repE e =
+ pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
repListExp (MkC es) = rep2 listExpName [es]
+repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
+repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
+
repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+repNeg :: Core M.Expr -> DsM (Core M.Expr)
+repNeg (MkC x) = rep2 negName [x]
+
repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
-- Literals
repLiteral :: HsLit -> DsM (Core M.Lit)
-repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
-repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
-repLiteral x = panic "trying to represent exotic literal"
-
-repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
-repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
-repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
+repLiteral lit
+ = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
+ where
+ lit_name = case lit of
+ HsInt _ -> intLName
+ HsChar _ -> charLName
+ HsString _ -> stringLName
+ HsRat _ _ -> rationalLName
+ other -> uh_oh
+ uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
+ (ppr lit)
--------------- Miscellaneous -------------------
-- The names that are implicitly mentioned by ``bracket''
-- Should stay in sync with the import list of DsMeta
templateHaskellNames
- = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
+ = mkNameSet [ intLName,charLName, stringLName, rationalLName,
+ plitName, pvarName, ptupName,
pconName, ptildeName, paspatName, pwildName,
varName, conName, litName, appName, infixEName, lamName,
tupName, doEName, compName,
- listExpName, condName, letEName, caseEName,
- infixAppName, sectionLName, sectionRName, guardedName, normalName,
+ listExpName, sigExpName, condName, letEName, caseEName,
+ infixAppName, negName, sectionLName, sectionRName,
+ guardedName, normalName,
bindStName, letStName, noBindStName, parStName,
fromName, fromThenName, fromToName, fromThenToName,
funName, valName, liftName,
-- NB: the THSyntax module comes from the "haskell-src" package
thModule = mkThPkgModule mETA_META_Name
-mk_known_key_name space mod str uniq
+mk_known_key_name space str uniq
= mkKnownKeyExternalName thModule (mkOccFS space str) uniq
intLName = varQual FSLIT("intL") intLIdKey
charLName = varQual FSLIT("charL") charLIdKey
+stringLName = varQual FSLIT("stringL") stringLIdKey
+rationalLName = varQual FSLIT("rationalL") rationalLIdKey
plitName = varQual FSLIT("plit") plitIdKey
pvarName = varQual FSLIT("pvar") pvarIdKey
ptupName = varQual FSLIT("ptup") ptupIdKey
doEName = varQual FSLIT("doE") doEIdKey
compName = varQual FSLIT("comp") compIdKey
listExpName = varQual FSLIT("listExp") listExpIdKey
+sigExpName = varQual FSLIT("sigExp") sigExpIdKey
condName = varQual FSLIT("cond") condIdKey
letEName = varQual FSLIT("letE") letEIdKey
caseEName = varQual FSLIT("caseE") caseEIdKey
infixAppName = varQual FSLIT("infixApp") infixAppIdKey
+negName = varQual FSLIT("neg") negIdKey
sectionLName = varQual FSLIT("sectionL") sectionLIdKey
sectionRName = varQual FSLIT("sectionR") sectionRIdKey
guardedName = varQual FSLIT("guarded") guardedIdKey
letEIdKey = mkPreludeMiscIdUnique 239
caseEIdKey = mkPreludeMiscIdUnique 240
infixAppIdKey = mkPreludeMiscIdUnique 241
-sectionLIdKey = mkPreludeMiscIdUnique 242
-sectionRIdKey = mkPreludeMiscIdUnique 243
-guardedIdKey = mkPreludeMiscIdUnique 244
-normalIdKey = mkPreludeMiscIdUnique 245
-bindStIdKey = mkPreludeMiscIdUnique 246
-letStIdKey = mkPreludeMiscIdUnique 247
-noBindStIdKey = mkPreludeMiscIdUnique 248
-parStIdKey = mkPreludeMiscIdUnique 249
-
-tvarIdKey = mkPreludeMiscIdUnique 250
-tconIdKey = mkPreludeMiscIdUnique 251
-tappIdKey = mkPreludeMiscIdUnique 252
-
-arrowIdKey = mkPreludeMiscIdUnique 253
-tupleIdKey = mkPreludeMiscIdUnique 254
-listIdKey = mkPreludeMiscIdUnique 255
-namedTyConIdKey = mkPreludeMiscIdUnique 256
-
-constrIdKey = mkPreludeMiscIdUnique 257
+negIdKey = mkPreludeMiscIdUnique 242
+sectionLIdKey = mkPreludeMiscIdUnique 243
+sectionRIdKey = mkPreludeMiscIdUnique 244
+guardedIdKey = mkPreludeMiscIdUnique 245
+normalIdKey = mkPreludeMiscIdUnique 246
+bindStIdKey = mkPreludeMiscIdUnique 247
+letStIdKey = mkPreludeMiscIdUnique 248
+noBindStIdKey = mkPreludeMiscIdUnique 249
+parStIdKey = mkPreludeMiscIdUnique 250
+
+tvarIdKey = mkPreludeMiscIdUnique 251
+tconIdKey = mkPreludeMiscIdUnique 252
+tappIdKey = mkPreludeMiscIdUnique 253
+
+arrowIdKey = mkPreludeMiscIdUnique 254
+tupleIdKey = mkPreludeMiscIdUnique 255
+listIdKey = mkPreludeMiscIdUnique 256
+namedTyConIdKey = mkPreludeMiscIdUnique 257
+
+constrIdKey = mkPreludeMiscIdUnique 258
+
+stringLIdKey = mkPreludeMiscIdUnique 259
+rationalLIdKey = mkPreludeMiscIdUnique 260
+
+sigExpIdKey = mkPreludeMiscIdUnique 261
+
+
-- %************************************************************************
-- %* *
projects / ghc-hetmet.git / blobdiff