import HsSyn
import Class (FunDep)
import PrelNames ( rationalTyConName, integerTyConName, negateName )
-import OccName ( isDataOcc, isTvOcc, occNameUserString )
+import OccName ( isDataOcc, isTvOcc, occNameString )
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
-- a qualified instance of OccName and using OccNameAlias.varName where varName
-- ws previously used in this file.
import qualified OccName
-import Module ( Module, mkModule, moduleUserString )
+import Module ( Module, mkModule, moduleString )
import Id ( Id, mkLocalId )
-import OccName ( mkOccFS )
+import OccName ( mkOccNameFS )
import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
isExternalName, getSrcLoc )
import NameEnv
-import Type ( Type, mkGenTyConApp )
+import Type ( Type, mkTyConApp )
import TcType ( tcTyConAppArgs )
import TyCon ( tyConName )
import TysWiredIn ( parrTyCon )
-------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con [] (L _ []) details))
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
= do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
-repC (L loc (ConDecl con tvs (L cloc ctxt) details))
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
= do { addTyVarBinds tvs $ \bndrs -> do {
- c' <- repC (L loc (ConDecl con [] (L cloc []) details));
+ c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
ctxt' <- repContext ctxt;
bndrs' <- coreList nameTyConName bndrs;
rep2 forallCName [unC bndrs', unC ctxt', unC c']
}
}
-repC (L loc con_decl)
+repC (L loc con_decl) -- GADTs
= putSrcSpanDs loc $
do { dsWarn (hang ds_msg 4 (ppr con_decl))
; return (panic "DsMeta:repC") }
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
-rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
-rep_sig other = return []
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other = return []
rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
-- 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 (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _))
+rep_bind (L loc (FunBind { fun_id = fn,
+ fun_matches = 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 (MatchGroup ms _) _))
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = 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_lhs = pat, pat_rhs = GRHSs guards wheres }))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans' <- wrapGenSyns ss ans
; return (loc, ans') }
-rep_bind (L loc (VarBind v e))
+rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
; e2 <- repLE e
; x <- repNormal e2
repLP (L _ p) = repP p
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' }
-repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
-repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p) = repLP p
-repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs }
+repP (WildPat _) = repPwild
+repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
+repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (ParPat p) = repLP p
+repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
+repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
= do { mb_val <- dsLookupMetaEnv n;
case mb_val of
Just (Bound x) -> return (coreVar x)
- other -> pprPanic "Failed binder lookup:" (ppr n) }
+ other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
-- Look up a name that is either locally bound or a global name
--
; MkC uni <- coreIntLit (getKey (getUnique name))
; rep2 mkNameLName [occ,uni] }
where
- name_mod = moduleUserString (nameModule name)
+ name_mod = moduleString (nameModule name)
name_occ = nameOccName name
mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
| OccName.isVarOcc name_occ = mkNameG_vName
lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
-> DsM Type -- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
- return (mkGenTyConApp tc []) }
+ return (mkTyConApp tc []) }
wrapGenSyns :: [GenSymBind]
-> Core (TH.Q a) -> DsM (Core (TH.Q a))
; return (NonRec id var) }
occNameLit :: Name -> DsM (Core String)
-occNameLit n = coreStringLit (occNameUserString (nameOccName n))
+occNameLit n = coreStringLit (occNameString (nameOccName n))
-- %*********************************************************************
thLib = mkModule "Language.Haskell.TH.Lib"
mk_known_key_name mod space str uniq
- = mkExternalName uniq mod (mkOccFS space str)
+ = mkExternalName uniq mod (mkOccNameFS space str)
Nothing noSrcLoc
libFun = mk_known_key_name thLib OccName.varName
projects / ghc-hetmet.git / blobdiff