summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Coverage.hs20
-rw-r--r--compiler/deSugar/Desugar.hs3
-rw-r--r--compiler/deSugar/DsBinds.hs31
-rw-r--r--compiler/deSugar/DsExpr.hs2
4 files changed, 32 insertions, 24 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index b44e9d8fa4..f5a9290e48 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -461,16 +461,15 @@ addBinTickLHsExpr boxLabel (L pos e0)
-- Decoarate an HsExpr with ticks
addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
-addTickHsExpr e@(HsVar id) = do freeVar id; return e
-addTickHsExpr e@(HsIPVar _) = return e
-addTickHsExpr e@(HsOverLit _) = return e
-addTickHsExpr e@(HsLit _) = return e
-addTickHsExpr (HsLam matchgroup) =
- liftM HsLam (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase ty mgs) =
- liftM (HsLamCase ty) (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2) =
- liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
+addTickHsExpr e@(HsVar id) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsIPVar _) = return e
+addTickHsExpr e@(HsOverLit _) = return e
+addTickHsExpr e@(HsLit _) = return e
+addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
+
addTickHsExpr (OpApp e1 e2 fix e3) =
liftM4 OpApp
(addTickLHsExpr e1)
@@ -599,7 +598,6 @@ addTickHsExpr (HsWrap w e) =
(addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr e@(HsType _) = return e
-addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 2e84560f9e..e3a31b9caa 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -356,6 +356,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
; rhs' <- dsLExpr rhs
; dflags <- getDynFlags
+ ; this_mod <- getModule
; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
@@ -371,7 +372,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
-- because they don't show up in the bindings until just before code gen
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
- rule = mkRule False {- Not auto -} is_local
+ rule = mkRule this_mod False {- Not auto -} is_local
(snd $ unLoc name) act fn_name final_bndrs args
final_rhs
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index e1d2c2a345..eedc318017 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -48,7 +48,8 @@ import Type
import Kind (returnsConstraintKind)
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
- , mkBoxedTupleTy, stringTy, instanceOfNewtypeAxiom )
+ , mkBoxedTupleTy, stringTy, typeNatKind, typeSymbolKind
+ , instanceOfNewtypeAxiom )
import Id
import MkId(proxyHashId)
import Class
@@ -445,6 +446,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
Right (rule_bndrs, _fn, args) -> do
{ dflags <- getDynFlags
+ ; this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
@@ -452,7 +454,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
- rule = mkRule False {- Not auto -} is_local_id
+ rule = mkRule this_mod False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
rule_bndrs args
@@ -859,7 +861,7 @@ dsEvTerm (EvSuperClass d n)
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
- errorId = rUNTIME_ERROR_ID
+ errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
dsEvTerm (EvLit l) =
@@ -915,14 +917,9 @@ dsEvTypeable ev =
, mkApps (Var ctr) [ e1, e2 ]
)
- EvTypeableTyLit ty ->
- do str <- case (isNumLitTy ty, isStrLitTy ty) of
- (Just n, _) -> return (show n)
- (_, Just n) -> return (show n)
- _ -> panic "dsEvTypeable: malformed TyLit evidence"
- ctr <- dsLookupGlobalId typeLitTypeRepName
- tag <- mkStringExpr str
- return (ty, mkApps (Var ctr) [ tag ])
+ EvTypeableTyLit t ->
+ do e <- tyLitRep t
+ return (snd t, e)
-- TyRep -> Typeable t
-- see also: Note [Memoising typeOf]
@@ -949,6 +946,18 @@ dsEvTypeable ev =
proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
return (mkApps method [proxy])
+ -- KnownNat t -> TyRep (also used for KnownSymbol)
+ tyLitRep (ev,t) =
+ do dict <- dsEvTerm ev
+ fun <- dsLookupGlobalId $
+ case typeKind t of
+ k | eqType k typeNatKind -> typeNatTypeRepName
+ | eqType k typeSymbolKind -> typeSymbolTypeRepName
+ | otherwise -> panic "dsEvTypeable: unknown type lit kind"
+ let finst = mkTyApps (Var fun) [t]
+ proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
+ return (mkApps finst [ dict, proxy ])
+
-- This part could be cached
tyConRep dflags mkTyCon tc =
do pkgStr <- mkStringExprFS pkg_fs
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 66f1758a03..a6cb98d372 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -191,6 +191,7 @@ dsExpr :: HsExpr Id -> DsM CoreExpr
dsExpr (HsPar e) = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
+dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
@@ -216,7 +217,6 @@ dsExpr (HsLamCase arg matches)
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
-dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
{-
Note [Desugaring vars]
View Lorry Controller Status