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
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
-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:")
+
+-- 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 ->
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 (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
-------------------------------------------------------
-repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name])
+repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
repDerivs Nothing = coreList nameTyConName []
-repDerivs (Just (L _ ctxt))
+repDerivs (Just ctxt)
= do { strs <- mapM rep_deriv ctxt ;
coreList nameTyConName strs }
where
- rep_deriv :: LHsPred Name -> DsM (Core TH.Name)
+ rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
- rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls
- rep_deriv other = panic "rep_deriv"
+ rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
+ rep_deriv other = panic "rep_deriv"
-------------------------------------------------------
repTy (HsParTy t) = repLTy t
repTy (HsNumTy i) =
panic "DsMeta.repTy: Can't represent number types (for generics)"
-repTy (HsPredTy pred) = repLPred pred
+repTy (HsPredTy pred) = repPred pred
repTy (HsKindSig ty kind) =
panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
-- 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
repGuards [L _ (GRHS [L _ (ResultStmt e)])]
= do {a <- repLE e; repNormal a }
repGuards other
- = do { zs <- mapM process other;
- repGuarded (nonEmptyCoreList (map corePair zs)) }
+ = do { zs <- mapM process other;
+ let {(xs, ys) = unzip zs};
+ gd <- repGuarded (nonEmptyCoreList ys);
+ wrapGenSyns (concat xs) gd }
where
+ process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+ process (L _ (GRHS [])) = panic "No guards in guarded body"
process (L _ (GRHS [L _ (ExprStmt e1 ty),
L _ (ResultStmt e2)]))
- = do { x <- repLE e1; y <- repLE e2; return (x, y) }
- process other = panic "Non Haskell 98 guarded body"
-
-repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp])
+ = do { x <- repLNormalGE e1 e2;
+ return ([], x) }
+ process (L _ (GRHS ss))
+ = do (gs, ss') <- repLSts ss
+ g <- repPatGE (nonEmptyCoreList ss')
+ return (gs, g)
+
+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
-----------------------------------------------------------------------------
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
+repSts [] = panic "repSts ran out of statements"
repSts other = panic "Exotic Stmt in meta brackets"
-- 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
- ; p <- repPvar fn'
- ; ans <- repVal p guardcore wherecore
- ; return (loc, ans) }
+ ; fn' <- lookupLBinder fn
+ ; p <- repPvar fn'
+ ; ans <- repVal p guardcore wherecore
+ ; 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)
- ; ans <- repVal patcore guardcore wherecore
- ; return (loc, ans) }
+ ; ans <- repVal patcore guardcore wherecore
+ ; ans' <- wrapGenSyns ss ans
+ ; return (loc, ans') }
rep_bind (L loc (VarBind v e))
= do { v' <- lookupBinder v
-- (\ 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 (
-- variable should already appear in the environment.
-- Process a list of patterns
-repLPs :: [LPat Name] -> DsM (Core [TH.Pat])
+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
repLPs ps = do { ps' <- mapM repLP ps ;
- coreList patTyConName ps' }
+ coreList patQTyConName ps' }
-repLP :: LPat Name -> DsM (Core TH.Pat)
+repLP :: LPat Name -> DsM (Core TH.PatQ)
repLP (L _ p) = repP p
-repP :: Pat Name -> DsM (Core TH.Pat)
+repP :: Pat Name -> DsM (Core TH.PatQ)
repP (WildPat _) = repPwild
repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
; ps <- sequence $ map repLP (map snd pairs)
; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
- ; fps' <- coreList fieldPatTyConName fps
+ ; fps' <- coreList fieldPatQTyConName fps
; repPrec con_str fps' }
- InfixCon p1 p2 -> do { qs <- repLPs [p1,p2]; repPcon con_str qs }
+ InfixCon p1 p2 -> do { p1' <- repLP p1;
+ p2' <- repLP p2;
+ repPinfix p1' con_str p2' }
}
repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
repP other = panic "Exotic pattern inside meta brackets"
----------------------------------------------------------
-- %*********************************************************************
--------------- Patterns -----------------
-repPlit :: Core TH.Lit -> DsM (Core TH.Pat)
+repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
repPlit (MkC l) = rep2 litPName [l]
-repPvar :: Core TH.Name -> DsM (Core TH.Pat)
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
repPvar (MkC s) = rep2 varPName [s]
-repPtup :: Core [TH.Pat] -> DsM (Core TH.Pat)
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPtup (MkC ps) = rep2 tupPName [ps]
-repPcon :: Core TH.Name -> Core [TH.Pat] -> DsM (Core TH.Pat)
+repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
-repPrec :: Core TH.Name -> Core [(TH.Name,TH.Pat)] -> DsM (Core TH.Pat)
+repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
-repPtilde :: Core TH.Pat -> DsM (Core TH.Pat)
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
repPtilde (MkC p) = rep2 tildePName [p]
-repPaspat :: Core TH.Name -> Core TH.Pat -> DsM (Core TH.Pat)
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-repPwild :: DsM (Core TH.Pat)
+repPwild :: DsM (Core TH.PatQ)
repPwild = rep2 wildPName []
-repPlist :: Core [TH.Pat] -> DsM (Core TH.Pat)
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPlist (MkC ps) = rep2 listPName [ps]
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-repLam :: Core [TH.Pat] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
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]
repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
------------ Right hand sides (guarded expressions) ----
-repGuarded :: Core [(TH.ExpQ, TH.ExpQ)] -> DsM (Core TH.BodyQ)
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
repGuarded (MkC pairs) = rep2 guardedBName [pairs]
repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
repNormal (MkC e) = rep2 normalBName [e]
+------------ Guards ----
+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+ e' <- repLE e
+ repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) = rep2 patGEName [ss]
+
------------- Stmts -------------------
-repBindSt :: Core TH.Pat -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
------------ Match and Clause Tuples -----------
-repMatch :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-repClause :: Core [TH.Pat] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-------------- Dec -----------------------------
-repVal :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
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)))
charLName, stringLName, integerLName, intPrimLName,
floatPrimLName, doublePrimLName, rationalLName,
-- Pat
- litPName, varPName, tupPName, conPName, tildePName,
- asPName, wildPName, recPName, listPName,
+ litPName, varPName, tupPName, conPName, tildePName, infixPName,
+ asPName, wildPName, recPName, listPName, sigPName,
-- FieldPat
fieldPatName,
-- Match
fieldExpName,
-- Body
guardedBName, normalBName,
+ -- Guard
+ normalGEName, patGEName,
-- Stmt
bindSName, letSName, noBindSName, parSName,
-- Dec
-- 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,
clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
- typeTyConName, matchTyConName, clauseTyConName]
+ typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
+ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
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
varPName = libFun FSLIT("varP") varPIdKey
tupPName = libFun FSLIT("tupP") tupPIdKey
conPName = libFun FSLIT("conP") conPIdKey
+infixPName = libFun FSLIT("infixP") infixPIdKey
tildePName = libFun FSLIT("tildeP") tildePIdKey
asPName = libFun FSLIT("asP") asPIdKey
wildPName = libFun FSLIT("wildP") wildPIdKey
recPName = libFun FSLIT("recP") recPIdKey
listPName = libFun FSLIT("listP") listPIdKey
+sigPName = libFun FSLIT("sigP") sigPIdKey
-- type FieldPat = ...
fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
guardedBName = libFun FSLIT("guardedB") guardedBIdKey
normalBName = libFun FSLIT("normalB") normalBIdKey
+-- data Guard = ...
+normalGEName = libFun FSLIT("normalGE") normalGEIdKey
+patGEName = libFun FSLIT("patGE") patGEIdKey
+
-- data Stmt = ...
bindSName = libFun FSLIT("bindS") bindSIdKey
letSName = libFun FSLIT("letS") letSIdKey
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
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
strictTypeQTyConKey = mkPreludeTyConUnique 115
fieldExpTyConKey = mkPreludeTyConUnique 116
fieldPatTyConKey = mkPreludeTyConUnique 117
-nameTyConKey = mkPreludeTyConUnique 118
+nameTyConKey = mkPreludeTyConUnique 118
+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
varPIdKey = mkPreludeMiscIdUnique 221
tupPIdKey = mkPreludeMiscIdUnique 222
conPIdKey = mkPreludeMiscIdUnique 223
+infixPIdKey = mkPreludeMiscIdUnique 312
tildePIdKey = mkPreludeMiscIdUnique 224
asPIdKey = mkPreludeMiscIdUnique 225
wildPIdKey = mkPreludeMiscIdUnique 226
recPIdKey = mkPreludeMiscIdUnique 227
listPIdKey = mkPreludeMiscIdUnique 228
+sigPIdKey = mkPreludeMiscIdUnique 229
-- type FieldPat = ...
fieldPatIdKey = mkPreludeMiscIdUnique 230
guardedBIdKey = mkPreludeMiscIdUnique 266
normalBIdKey = mkPreludeMiscIdUnique 267
+-- data Guard = ...
+normalGEIdKey = mkPreludeMiscIdUnique 310
+patGEIdKey = mkPreludeMiscIdUnique 311
+
-- data Stmt = ...
bindSIdKey = mkPreludeMiscIdUnique 268
letSIdKey = mkPreludeMiscIdUnique 269
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