Permalink
Browse files

Injective type families

For details see #6018, Phab:D202 and the wiki page:

https://ghc.haskell.org/trac/ghc/wiki/InjectiveTypeFamilies

This patch also wires-in Maybe data type and updates haddock submodule.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari

Subscribers: mpickering, bgamari, alanz, thomie, goldfire, simonmar,
             carter

Differential Revision: https://phabricator.haskell.org/D202

GHC Trac Issues: #6018
  • Loading branch information...
jstolarek committed Jul 11, 2014
1 parent bd16e0b commit 374457809de343f409fbeea0a885877947a133a2
Showing with 3,963 additions and 843 deletions.
  1. +5 −3 compiler/basicTypes/MkId.hs
  2. +3 −2 compiler/basicTypes/VarSet.hs
  3. +21 −0 compiler/coreSyn/MkCore.hs
  4. +124 −56 compiler/deSugar/DsMeta.hs
  5. +42 −14 compiler/hsSyn/Convert.hs
  6. +240 −95 compiler/hsSyn/HsDecls.hs
  7. +1 −1 compiler/hsSyn/HsTypes.hs
  8. +1 −1 compiler/hsSyn/PlaceHolder.hs
  9. +13 −9 compiler/iface/BuildTyCl.hs
  10. +27 −8 compiler/iface/IfaceSyn.hs
  11. +6 −3 compiler/iface/MkIface.hs
  12. +7 −4 compiler/iface/TcIface.hs
  13. +2 −2 compiler/main/GHC.hs
  14. +1 −1 compiler/parser/ApiAnnotation.hs
  15. +61 −18 compiler/parser/Parser.y
  16. +16 −13 compiler/parser/RdrHsSyn.hs
  17. +14 −12 compiler/prelude/PrelNames.hs
  18. +110 −86 compiler/prelude/THNames.hs
  19. +2 −1 compiler/prelude/TysPrim.hs
  20. +32 −6 compiler/prelude/TysWiredIn.hs
  21. +149 −15 compiler/rename/RnSource.hs
  22. +40 −18 compiler/rename/RnTypes.hs
  23. +165 −22 compiler/typecheck/FamInst.hs
  24. +3 −3 compiler/typecheck/TcCanonical.hs
  25. +2 −1 compiler/typecheck/TcEnv.hs
  26. +2 −2 compiler/typecheck/TcEvidence.hs
  27. +10 −8 compiler/typecheck/TcHsType.hs
  28. +8 −8 compiler/typecheck/TcInstDcls.hs
  29. +232 −86 compiler/typecheck/TcInteract.hs
  30. +15 −12 compiler/typecheck/TcMType.hs
  31. +5 −1 compiler/typecheck/TcRnDriver.hs
  32. +13 −0 compiler/typecheck/TcRnMonad.hs
  33. +112 −54 compiler/typecheck/TcSMonad.hs
  34. +49 −29 compiler/typecheck/TcSplice.hs
  35. +106 −76 compiler/typecheck/TcTyClsDecls.hs
  36. +10 −2 compiler/typecheck/TcTypeNats.hs
  37. +68 −4 compiler/typecheck/TcValidity.hs
  38. +13 −5 compiler/types/CoAxiom.hs
  39. +2 −1 compiler/types/Coercion.hs
  40. +299 −36 compiler/types/FamInstEnv.hs
  41. +6 −5 compiler/types/Kind.hs
  42. +2 −2 compiler/types/OptCoercion.hs
  43. +71 −10 compiler/types/TyCon.hs
  44. +5 −6 compiler/types/TypeRep.hs
  45. +3 −0 compiler/types/TypeRep.hs-boot
  46. +59 −2 compiler/types/Unify.hs
  47. +21 −1 compiler/utils/Outputable.hs
  48. +3 −0 compiler/utils/UniqFM.hs
  49. +10 −0 docs/users_guide/7.12.1-notes.xml
  50. +105 −0 docs/users_guide/glasgow_exts.xml
  51. +7 −6 libraries/template-haskell/Language/Haskell/TH.hs
  52. +68 −18 libraries/template-haskell/Language/Haskell/TH/Lib.hs
  53. +39 −22 libraries/template-haskell/Language/Haskell/TH/Ppr.hs
  54. +4 −2 libraries/template-haskell/Language/Haskell/TH/PprLib.hs
  55. +24 −5 libraries/template-haskell/Language/Haskell/TH/Syntax.hs
  56. +1 −1 testsuite/tests/ghci.debugger/scripts/print019.stderr
  57. +22 −0 testsuite/tests/ghci/scripts/T6018ghci.script
  58. 0 testsuite/tests/ghci/scripts/T6018ghci.stdout
  59. +114 −0 testsuite/tests/ghci/scripts/T6018ghcifail.script
  60. +111 −0 testsuite/tests/ghci/scripts/T6018ghcifail.stderr
  61. +42 −0 testsuite/tests/ghci/scripts/T6018ghcirnfail.script
  62. +63 −0 testsuite/tests/ghci/scripts/T6018ghcirnfail.stderr
  63. +3 −0 testsuite/tests/ghci/scripts/all.T
  64. +1 −1 testsuite/tests/indexed-types/should_compile/T9085.stderr
  65. +1 −2 testsuite/tests/indexed-types/should_fail/T9160.hs
  66. +1 −1 testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
  67. +1 −2 testsuite/tests/quotes/TH_localname.stderr
  68. +54 −0 testsuite/tests/rename/should_fail/T6018rnfail.hs
  69. +71 −0 testsuite/tests/rename/should_fail/T6018rnfail.stderr
  70. +1 −0 testsuite/tests/rename/should_fail/all.T
  71. +1 −2 testsuite/tests/rename/should_fail/mc14.stderr
  72. +12 −10 testsuite/tests/th/ClosedFam2TH.hs
  73. +2 −2 testsuite/tests/th/T10306.hs
  74. +120 −0 testsuite/tests/th/T6018th.hs
  75. +6 −0 testsuite/tests/th/T6018th.stderr
  76. +2 −2 testsuite/tests/th/T8028.hs
  77. +1 −1 testsuite/tests/th/T8028a.hs
  78. +7 −6 testsuite/tests/th/T8884.hs
  79. +4 −3 testsuite/tests/th/T8884.stderr
  80. +2 −2 testsuite/tests/th/TH_RichKinds2.hs
  81. +0 −2 testsuite/tests/th/TH_reifyDecl1.hs
  82. +1 −0 testsuite/tests/th/all.T
  83. +254 −0 testsuite/tests/typecheck/should_compile/T6018.hs
  84. +7 −0 testsuite/tests/typecheck/should_compile/T6018.hs-boot
  85. +11 −0 testsuite/tests/typecheck/should_compile/T6018.stderr
  86. +11 −0 testsuite/tests/typecheck/should_compile/T6018a.hs
  87. +4 −0 testsuite/tests/typecheck/should_compile/all.T
  88. +1 −1 testsuite/tests/typecheck/should_compile/holes2.stderr
  89. +8 −0 testsuite/tests/typecheck/should_compile/tc265.hs
  90. +4 −0 testsuite/tests/typecheck/should_compile/tc265.stderr
  91. +7 −0 testsuite/tests/typecheck/should_fail/T6018Afail.hs
  92. +5 −0 testsuite/tests/typecheck/should_fail/T6018Bfail.hs
  93. +8 −0 testsuite/tests/typecheck/should_fail/T6018Cfail.hs
  94. +7 −0 testsuite/tests/typecheck/should_fail/T6018Dfail.hs
  95. +134 −0 testsuite/tests/typecheck/should_fail/T6018fail.hs
  96. +149 −0 testsuite/tests/typecheck/should_fail/T6018fail.stderr
  97. +11 −0 testsuite/tests/typecheck/should_fail/T6018failclosed1.hs
  98. +7 −0 testsuite/tests/typecheck/should_fail/T6018failclosed1.stderr
  99. +17 −0 testsuite/tests/typecheck/should_fail/T6018failclosed10.hs
  100. +9 −0 testsuite/tests/typecheck/should_fail/T6018failclosed10.stderr
  101. +15 −0 testsuite/tests/typecheck/should_fail/T6018failclosed11.hs
  102. +7 −0 testsuite/tests/typecheck/should_fail/T6018failclosed11.stderr
  103. +7 −0 testsuite/tests/typecheck/should_fail/T6018failclosed12.hs
  104. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed12.stderr
  105. +12 −0 testsuite/tests/typecheck/should_fail/T6018failclosed2.hs
  106. +16 −0 testsuite/tests/typecheck/should_fail/T6018failclosed2.stderr
  107. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed3.hs
  108. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed3.stderr
  109. +10 −0 testsuite/tests/typecheck/should_fail/T6018failclosed4.hs
  110. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed4.stderr
  111. +12 −0 testsuite/tests/typecheck/should_fail/T6018failclosed5.hs
  112. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed5.stderr
  113. +7 −0 testsuite/tests/typecheck/should_fail/T6018failclosed6.hs
  114. +9 −0 testsuite/tests/typecheck/should_fail/T6018failclosed6.stderr
  115. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed7.hs
  116. +7 −0 testsuite/tests/typecheck/should_fail/T6018failclosed7.stderr
  117. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed8.hs
  118. +7 −0 testsuite/tests/typecheck/should_fail/T6018failclosed8.stderr
  119. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed9.hs
  120. +8 −0 testsuite/tests/typecheck/should_fail/T6018failclosed9.stderr
  121. +1 −1 testsuite/tests/typecheck/should_fail/T9201.stderr
  122. +2 −3 testsuite/tests/typecheck/should_fail/T9260.stderr
  123. +18 −0 testsuite/tests/typecheck/should_fail/all.T
  124. +1 −1 testsuite/tests/typecheck/should_fail/tcfail072.stderr
  125. +2 −1 testsuite/tests/typecheck/should_fail/tcfail133.stderr
  126. +1 −1 testsuite/tests/typecheck/should_fail/tcfail181.stderr
  127. +1 −1 utils/haddock
@@ -12,7 +12,7 @@ have a standard form, namely:
- primitive operations
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, DataKinds #-}
module MkId (
mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
@@ -911,7 +911,8 @@ wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args body
= mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr
-> CoreExpr
wrapTypeUnbranchedFamInstBody axiom
= wrapTypeFamInstBody axiom 0
@@ -926,7 +927,8 @@ unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom ind args scrut
= mkCast scrut (mkAxInstCo Representational axiom ind args)
unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr
-> CoreExpr
unwrapTypeUnbranchedFamInstScrut axiom
= unwrapTypeFamInstScrut axiom 0
@@ -27,6 +27,7 @@ module VarSet (
import Var ( Var, TyVar, CoVar, Id )
import Unique
import UniqSet
import UniqFM( disjointUFM )
{-
************************************************************************
@@ -98,7 +99,7 @@ lookupVarSet = lookupUniqSet
mapVarSet = mapUniqSet
sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
extendVarSet_C = addOneToUniqSet_C
extendVarSet_C = addOneToUniqSet_C
delVarSetByKey = delOneFromUniqSet_Directly
elemVarSetByKey = elemUniqSet_Directly
partitionVarSet = partitionUniqSet
@@ -107,7 +108,7 @@ mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs
-- See comments with type signatures
intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
disjointVarSet s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2)
disjointVarSet s1 s2 = disjointUFM s1 s2
subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set
View
@@ -43,6 +43,9 @@ module MkCore (
mkNilExpr, mkConsExpr, mkListExpr,
mkFoldrExpr, mkBuildExpr,
-- * Constructing Maybe expressions
mkNothingExpr, mkJustExpr,
-- * Error Ids
mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
@@ -602,6 +605,24 @@ mkBuildExpr elt_ty mk_build_inside = do
uniqs <- getUniquesM
return (zipWith setTyVarUnique tyvar_tmpls uniqs)
{-
************************************************************************
* *
Manipulating Maybe data type
* *
************************************************************************
-}
-- | Makes a Nothing for the specified type
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr ty = mkConApp nothingDataCon [Type ty]
-- | Makes a Just from a value of the specified type
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
{-
************************************************************************
* *
View
@@ -310,34 +310,69 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdLName = tc,
fdTyVars = tvs,
fdKindSig = opt_kind }))
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdLName = tc,
fdTyVars = tvs,
fdResultSig = L _ resultSig,
fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
resTyVar = case resultSig of
TyVarSig bndr -> mkHsQTvs [bndr]
_ -> mkHsQTvs []
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
case (opt_kind, info) of
(_ , ClosedTypeFamily Nothing) ->
notHandled "abstract closed type family" (ppr decl)
(Nothing, ClosedTypeFamily (Just eqns)) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; repClosedFamilyNoKind tc1 bndrs eqns2 }
(Just ki, ClosedTypeFamily (Just eqns)) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; ki1 <- repLKind ki
; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
(Nothing, _) ->
do { info' <- repFamilyInfo info
; repFamilyNoKind info' tc1 bndrs }
(Just ki, _) ->
do { info' <- repFamilyInfo info
; ki1 <- repLKind ki
; repFamilyKind info' tc1 bndrs ki1 }
addTyClTyVarBinds resTyVar $ \_ ->
case info of
ClosedTypeFamily Nothing ->
notHandled "abstract closed type family" (ppr decl)
ClosedTypeFamily (Just eqns) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; result <- repFamilyResultSig resultSig
; inj <- repInjectivityAnn injectivity
; repClosedFamilyD tc1 bndrs result inj eqns2 }
OpenTypeFamily ->
do { result <- repFamilyResultSig resultSig
; inj <- repInjectivityAnn injectivity
; repOpenFamilyD tc1 bndrs result inj }
DataFamily ->
do { kind <- repFamilyResultSigToMaybeKind resultSig
; repDataFamilyD tc1 bndrs kind }
; return (loc, dec)
}
-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig)
repFamilyResultSig NoSig = repNoSig
repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki
; repKindSig ki' }
repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
; repTyVarSig bndr' }
-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
-- result variable.
repFamilyResultSigToMaybeKind :: FamilyResultSig Name
-> DsM (Core (Maybe TH.Kind))
repFamilyResultSigToMaybeKind NoSig =
do { coreNothing kindTyConName }
repFamilyResultSigToMaybeKind (KindSig ki) =
do { ki' <- repLKind ki
; coreJust kindTyConName ki' }
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn Name)
-> DsM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
do { coreNothing injAnnTyConName }
repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
do { lhs' <- lookupBinder (unLoc lhs)
; rhs1 <- mapM (lookupBinder . unLoc) rhs
; rhs2 <- coreList nameTyConName rhs1
; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
; coreJust injAnnTyConName injAnn }
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
@@ -381,13 +416,6 @@ repLFunDep (L _ (xs, ys))
ys' <- repList nameTyConName (lookupBinder . unLoc) ys
repFunDep xs' ys'
-- represent family declaration flavours
--
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily = rep2 typeFamName []
repFamilyInfo DataFamily = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
@@ -831,6 +859,14 @@ repTyVarBndrWithKind (L _ (UserTyVar _)) nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
= repLKind ki >>= repKindedTV nm
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
repTyVarBndr (L _ (UserTyVar nm)) = do { nm' <- lookupBinder nm
; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
; ki' <- repLKind ki
; repKindedTV nm' ki' }
-- represent a type context
--
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
@@ -1827,35 +1863,31 @@ repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
-> DsM (Core TH.DecQ)
repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
= rep2 familyNoKindDName [flav, nm, tvs]
repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
-> Core TH.Kind
-> DsM (Core TH.DecQ)
repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
= rep2 familyKindDName [flav, nm, tvs, ki]
repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
repTySynInst (MkC nm) (MkC eqn)
= rep2 tySynInstDName [nm, eqn]
repClosedFamilyNoKind :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
= rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
repClosedFamilyKind :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core TH.Kind
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
= rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]
-> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)
repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
= rep2 dataFamilyDName [nm, tvs, kind]
repOpenFamilyD :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core TH.FamilyResultSig
-> Core (Maybe TH.InjectivityAnn)
-> DsM (Core TH.DecQ)
repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
= rep2 openTypeFamilyDName [nm, tvs, result, inj]
repClosedFamilyD :: Core TH.Name
-> Core [TH.TyVarBndr]
-> Core TH.FamilyResultSig
-> Core (Maybe TH.InjectivityAnn)
-> Core [TH.TySynEqnQ]
-> DsM (Core TH.DecQ)
repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
= rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
repTySynEqn (MkC lhs) (MkC rhs)
@@ -2006,6 +2038,18 @@ repKStar = rep2 starKName []
repKConstraint :: DsM (Core TH.Kind)
repKConstraint = rep2 constraintKName []
----------------------------------------------------------
-- Type family result signature
repNoSig :: DsM (Core TH.FamilyResultSig)
repNoSig = rep2 noSigName []
repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)
repKindSig (MkC ki) = rep2 kindSigName [ki]
repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)
repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
----------------------------------------------------------
-- Literals
@@ -2082,7 +2126,7 @@ repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
repSequenceQ ty_a (MkC list)
= rep2 sequenceQName [Type ty_a, list]
------------ Lists and Tuples -------------------
------------ Lists -------------------
-- turn a list of patterns into a single pattern matching a list
repList :: Name -> (a -> DsM (Core b))
@@ -2109,6 +2153,30 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------------- Maybe ------------------
-- | Construct Core expression for Nothing of a given type name
coreNothing :: Name -- ^ Name of the TyCon of the element type
-> DsM (Core (Maybe a))
coreNothing tc_name =
do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
-- | Construct Core expression for Nothing of a given type
coreNothing' :: Type -- ^ The element type
-> Core (Maybe a)
coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
-- | Store given Core expression in a Just of a given type name
coreJust :: Name -- ^ Name of the TyCon of the element type
-> Core a -> DsM (Core (Maybe a))
coreJust tc_name es
= do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
-- | Store given Core expression in a Just of a given type
coreJust' :: Type -- ^ The element type
-> Core a -> Core (Maybe a)
coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
------------ Literals & Variables -------------------
coreIntLit :: Int -> DsM (Core Int)
Oops, something went wrong.

0 comments on commit 3744578

Please sign in to comment.