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
import HsSyn
+import Class (FunDep)
import PrelNames ( rationalTyConName, integerTyConName, negateName )
import OccName ( isDataOcc, isTvOcc, occNameUserString )
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- ws previously used in this file.
import qualified OccName
-import Module ( Module, mkModule, mkModuleName, moduleUserString )
+import Module ( Module, mkModule, moduleUserString )
import Id ( Id, mkLocalId )
import OccName ( mkOccFS )
import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
import Maybe ( catMaybes )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
import BasicTypes ( isBoxed )
-import Packages ( thPackage )
import Outputable
import Bag ( bagToList )
import FastString ( unpackFS )
do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
- do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
+ do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
{- -------------- Examples --------------------
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs,
- tcdFDs = [], -- We don't understand functional dependencies
+ tcdFDs = fds,
tcdSigs = sigs, tcdMeths = meth_binds }))
= do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
dec <- addTyVarBinds tvs $ \bndrs -> do {
cxt1 <- repLContext cxt ;
sigs1 <- rep_sigs sigs ;
binds1 <- rep_binds meth_binds ;
+ fds1 <- repLFunDeps fds;
decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
bndrs1 <- coreList nameTyConName bndrs ;
- repClass cxt1 cls1 bndrs1 decls1 } ;
+ repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
return $ Just (loc, dec) }
-- Un-handled cases
return Nothing
}
+-- represent fundeps
+--
+repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
+repLFunDeps fds = do fds' <- mapM repLFunDep fds
+ fdList <- coreList funDepTyConName fds'
+ return fdList
+
+repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
+ ys' <- mapM lookupBinder ys
+ xs_list <- coreList nameTyConName xs'
+ ys_list <- coreList nameTyConName ys'
+ repFunDep xs_list ys_list
repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
= do { i <- addTyVarBinds tvs $ \tv_bndrs ->
repC (L loc (ConDecl con [] (L _ []) details))
= do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
-
+repC (L loc (ConDecl con tvs (L cloc ctxt) details))
+ = do { addTyVarBinds tvs $ \bndrs -> do {
+ c' <- repC (L loc (ConDecl con [] (L cloc []) details));
+ ctxt' <- repContext ctxt;
+ bndrs' <- coreList nameTyConName bndrs;
+ rep2 forallCName [unC bndrs', unC ctxt', unC c']
+ }
+ }
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
-- 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 (
| otherwise
= do { MkC occ <- occNameLit name
; MkC uni <- coreIntLit (getKey (getUnique name))
- ; rep2 mkNameUName [occ,uni] }
+ ; rep2 mkNameLName [occ,uni] }
where
name_mod = moduleUserString (nameModule name)
name_occ = nameOccName name
repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
-repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
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)))
templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName,
- mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName,
+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
-- Lit
charLName, stringLName, integerLName, intPrimLName,
-- Strict
isStrictName, notStrictName,
-- Con
- normalCName, recCName, infixCName,
+ normalCName, recCName, infixCName, forallCName,
-- StrictType
strictTypeName,
-- VarStrictType
unsafeName,
safeName,
threadsafeName,
+ -- FunDep
+ funDepName,
-- And the tycons
qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
- fieldPatQTyConName, fieldExpQTyConName]
-
-tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
-tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
+ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
thSyn :: Module
--- NB: the TH.Syntax module comes from the "template-haskell" package
-thSyn = mkModule thPackage tH_SYN_Name
-thLib = mkModule thPackage tH_LIB_Name
+thSyn = mkModule "Language.Haskell.TH.Syntax"
+thLib = mkModule "Language.Haskell.TH.Lib"
mk_known_key_name mod space str uniq
= mkExternalName uniq mod (mkOccFS space str)
thTc = mk_known_key_name thSyn OccName.tcName
-------------------- TH.Syntax -----------------------
-qTyConName = thTc FSLIT("Q") qTyConKey
-nameTyConName = thTc FSLIT("Name") nameTyConKey
-fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
-patTyConName = thTc FSLIT("Pat") patTyConKey
-fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
-expTyConName = thTc FSLIT("Exp") expTyConKey
-decTyConName = thTc FSLIT("Dec") decTyConKey
-typeTyConName = thTc FSLIT("Type") typeTyConKey
-matchTyConName = thTc FSLIT("Match") matchTyConKey
-clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
+qTyConName = thTc FSLIT("Q") qTyConKey
+nameTyConName = thTc FSLIT("Name") nameTyConKey
+fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
+patTyConName = thTc FSLIT("Pat") patTyConKey
+fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
+expTyConName = thTc FSLIT("Exp") expTyConKey
+decTyConName = thTc FSLIT("Dec") decTyConKey
+typeTyConName = thTc FSLIT("Type") typeTyConKey
+matchTyConName = thTc FSLIT("Match") matchTyConKey
+clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
+funDepTyConName = thTc FSLIT("FunDep") funDepTyConKey
returnQName = thFun FSLIT("returnQ") returnQIdKey
bindQName = thFun FSLIT("bindQ") bindQIdKey
mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
-mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey
+mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
-------------------- TH.Lib -----------------------
normalCName = libFun FSLIT("normalC") normalCIdKey
recCName = libFun FSLIT("recC") recCIdKey
infixCName = libFun FSLIT("infixC") infixCIdKey
+forallCName = libFun FSLIT("forallC") forallCIdKey
-- type StrictType = ...
strictTypeName = libFun FSLIT("strictType") strictTKey
safeName = libFun FSLIT("safe") safeIdKey
threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
+-- data FunDep = ...
+funDepName = libFun FSLIT("funDep") funDepIdKey
+
matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
patQTyConKey = mkPreludeTyConUnique 119
fieldPatQTyConKey = mkPreludeTyConUnique 120
fieldExpQTyConKey = mkPreludeTyConUnique 121
+funDepTyConKey = mkPreludeTyConUnique 122
-- IdUniques available: 200-399
-- If you want to change this, make sure you check in PrelNames
mkNameG_vIdKey = mkPreludeMiscIdUnique 206
mkNameG_dIdKey = mkPreludeMiscIdUnique 207
mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
-mkNameUIdKey = mkPreludeMiscIdUnique 209
+mkNameLIdKey = mkPreludeMiscIdUnique 209
-- data Lit = ...
normalCIdKey = mkPreludeMiscIdUnique 283
recCIdKey = mkPreludeMiscIdUnique 284
infixCIdKey = mkPreludeMiscIdUnique 285
+forallCIdKey = mkPreludeMiscIdUnique 288
-- type StrictType = ...
strictTKey = mkPreludeMiscIdUnique 286
safeIdKey = mkPreludeMiscIdUnique 306
threadsafeIdKey = mkPreludeMiscIdUnique 307
+-- data FunDep = ...
+funDepIdKey = mkPreludeMiscIdUnique 320
+
projects / ghc-hetmet.git / blobdiff