import {-# SOURCE #-} DsExpr ( dsExpr )
import MatchLit ( dsLit )
-import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
+import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
import DsMonad
import qualified Language.Haskell.TH as TH
return $ Just (loc, dec) }
-- Un-handled cases
-repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ;
+repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ;
return Nothing
}
- where
- msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
= do { i <- addTyVarBinds tvs $ \tv_bndrs ->
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []
+ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
-------------------------------------------------------
-- Constructors
-------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L loc (ConDecl con [] (L _ []) details))
- = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
+ = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
+repC (L loc con_decl)
+ = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
+ ; return (panic "DsMeta:repC") }
+ where
+-- gaw 2004 FIX! Need a case for GadtDecl
+
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
-repBangTy (L _ (BangType str ty)) = do
- MkC s <- rep2 strName []
- MkC t <- repLTy ty
+repBangTy ty= do
+ MkC s <- rep2 str []
+ MkC t <- repLTy ty'
rep2 strictTypeName [s, t]
- where strName = case str of
- HsNoBang -> notStrictName
- other -> isStrictName
+ where
+ (str, ty') = case ty of
+ L _ (HsBangTy _ ty) -> (isStrictName, ty)
+ other -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
-repE (HsLam m) = repLambda m
+repE (HsLam (MatchGroup [m] _)) = repLambda m
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (OpApp e1 op fix e2) =
repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e ms) = do { arg <- repLE e
- ; ms2 <- mapM repMatchTup ms
- ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsIf x y z) = do
a <- repLE x
b <- repLE y
-- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) =
+repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repLP p
; wrapGenSyns (ss1++ss2) match }}}
repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) =
+repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repLPs ps
g <- repPatGE (nonEmptyCoreList ss')
return (gs, g)
-repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp])
+repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
repFields flds = do
fnames <- mapM lookupLOcc (map fst flds)
es <- mapM repLE (map snd flds)
- fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
- coreList fieldExpTyConName fs
+ fs <- zipWithM repFieldExp fnames es
+ coreList fieldExpQTyConName fs
-----------------------------------------------------------------------------
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))]))
+rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _)))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
; ans' <- wrapGenSyns ss ans
; return (loc, ans') }
-rep_bind (L loc (FunBind fn infx ms))
+rep_bind (L loc (FunBind fn infx (MatchGroup ms _)))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
-rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2)))
+rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _)))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-repRecCon :: Core TH.Name -> Core [TH.FieldExp]-> DsM (Core TH.ExpQ)
-repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
-repRecUpd :: Core TH.ExpQ -> Core [TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
coreStringLit :: String -> DsM (Core String)
-coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
coreIntLit :: Int -> DsM (Core Int)
coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
- fieldPatQTyConName]
+ fieldPatQTyConName, fieldExpQTyConName]
tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
+fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc FSLIT("PatQ") patQTyConKey
fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
--- TyConUniques available: 100-119
+-- TyConUniques available: 100-129
-- Check in PrelNames if you want to change this
expTyConKey = mkPreludeTyConUnique 100
nameTyConKey = mkPreludeTyConUnique 118
patQTyConKey = mkPreludeTyConUnique 119
fieldPatQTyConKey = mkPreludeTyConUnique 120
+fieldExpQTyConKey = mkPreludeTyConUnique 121
-- IdUniques available: 200-399
-- If you want to change this, make sure you check in PrelNames
projects / ghc-hetmet.git / blobdiff