projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Do dependency analysis when kind-checking type declarations
[ghc-hetmet.git] / compiler / deSugar / DsMeta.hs
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 3f7f4d0..5da376b 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -106,7 +106,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
 
 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
- = do { let { bndrs = groupBinders group } ;
+ = do { let { bndrs = hsGroupBinders group } ;
        ss <- mkGenSyms bndrs ;
 
        -- Bind all the names mainly to avoid repeated use of explicit strings.
@@ -119,7 +119,7 @@ repTopDs group
        
        decls <- addBinds ss (do {
                        val_ds  <- rep_val_binds (hs_valds group) ;
-                       tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+                       tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
                        inst_ds <- mapM repInstD' (hs_instds group) ;
                        for_ds <- mapM repForD (hs_fords group) ;
                        -- more needed
@@ -135,16 +135,6 @@ repTopDs group
        -- Do *not* gensym top-level binders
       }
 
-groupBinders :: HsGroup Name -> [Name]
-groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
-                        hs_instds = inst_decls, hs_fords = foreign_decls })
--- Collect the binders of a Group
-  = collectHsValBinders val_decls ++
-    [n | d <- tycl_decls ++ assoc_tycl_decls, L _ n <- tyClDeclNames (unLoc d)] ++
-    [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
-  where
-    assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
-
 
 {-     Note [Binders and occurrences]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -359,6 +349,7 @@ repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
 
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []
+repSafety PlayInterruptible = rep2 interruptibleName []
 repSafety (PlaySafe False) = rep2 safeName []
 repSafety (PlaySafe True) = rep2 threadsafeName []
 
@@ -470,15 +461,17 @@ rep_specialise nm ty ispec loc
 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
                -> DsM (Core TH.InlineSpecQ)
 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
-  | Nothing            <- activation1 
-    = repInlineSpecNoPhase inline1 match1
   | Just (flag, phase) <- activation1 
-    = repInlineSpecPhase inline1 match1 flag phase
-  | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
-    where
+  = repInlineSpecPhase inline1 match1 flag phase
+  | otherwise
+  = repInlineSpecNoPhase inline1 match1
+  where
       match1      = coreBool (rep_RuleMatchInfo match)
       activation1 = rep_Activation activation
-      inline1     = coreBool inline
+      inline1     = case inline of 
+                       Inline -> coreBool True
+                      _other -> coreBool False
+                      -- We have no representation for Inlinable
 
       rep_RuleMatchInfo FunLike = False
       rep_RuleMatchInfo ConLike = True
@@ -713,7 +706,7 @@ repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
                                       ; ms2 <- mapM repMatchTup ms
                                       ; repCaseE arg (nonEmptyCoreList ms2) }
-repE (HsIf x y z)         = do
+repE (HsIf _ x y z)         = do
                              a <- repLE x
                              b <- repLE y
                              c <- repLE z
@@ -966,7 +959,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; ans <- repVal patcore x empty_decls
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
-rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
+rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
 
 -----------------------------------------------------------------------------
 -- Since everything in a Bind is mutually recursive we need rename all
@@ -1045,6 +1038,7 @@ repP (ConPatIn dc details)
                                 repPinfix p1' con_str p2' }
    }
 repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
+repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
        -- The problem is to do with scoped type variables.
@@ -1277,6 +1271,9 @@ repPwild = rep2 wildPName []
 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
 repPlist (MkC ps) = rep2 listPName [ps]
 
+repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+
 --------------- Expressions -----------------
 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
@@ -1301,7 +1298,7 @@ repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 repTup (MkC es) = rep2 tupEName [es]
 
 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z] 
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] 
 
 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 
@@ -1665,13 +1662,14 @@ templateHaskellNames :: [Name]
 templateHaskellNames = [
     returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, 
-
+    liftStringName,
+ 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
-    floatPrimLName, doublePrimLName, rationalLName,
+    floatPrimLName, doublePrimLName, rationalLName, 
     -- Pat
     litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
-    asPName, wildPName, recPName, listPName, sigPName,
+    asPName, wildPName, recPName, listPName, sigPName, viewPName,
     -- FieldPat
     fieldPatName,
     -- Match
@@ -1723,6 +1721,7 @@ templateHaskellNames = [
     unsafeName,
     safeName,
     threadsafeName,
+    interruptibleName,
     -- InlineSpec
     inlineSpecNoPhaseName, inlineSpecPhaseName,
     -- FunDep
@@ -1807,7 +1806,7 @@ rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
 
 -- data Pat = ...
 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
-    asPName, wildPName, recPName, listPName, sigPName :: Name
+    asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
 litPName   = libFun (fsLit "litP")   litPIdKey
 varPName   = libFun (fsLit "varP")   varPIdKey
 tupPName   = libFun (fsLit "tupP")   tupPIdKey
@@ -1820,6 +1819,7 @@ wildPName  = libFun (fsLit "wildP")  wildPIdKey
 recPName   = libFun (fsLit "recP")   recPIdKey
 listPName  = libFun (fsLit "listP")  listPIdKey
 sigPName   = libFun (fsLit "sigP")   sigPIdKey
+viewPName  = libFun (fsLit "viewP")  viewPIdKey
 
 -- type FieldPat = ...
 fieldPatName :: Name
@@ -1966,10 +1966,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey
 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
 
 -- data Safety = ...
-unsafeName, safeName, threadsafeName :: Name
+unsafeName, safeName, threadsafeName, interruptibleName :: Name
 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
 
 -- data InlineSpec = ...
 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
@@ -2084,7 +2085,7 @@ liftStringIdKey     = mkPreludeMiscIdUnique 218
 
 -- data Pat = ...
 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
-    asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
+    asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
 litPIdKey         = mkPreludeMiscIdUnique 220
 varPIdKey         = mkPreludeMiscIdUnique 221
 tupPIdKey         = mkPreludeMiscIdUnique 222
@@ -2097,6 +2098,7 @@ wildPIdKey        = mkPreludeMiscIdUnique 226
 recPIdKey         = mkPreludeMiscIdUnique 227
 listPIdKey        = mkPreludeMiscIdUnique 228
 sigPIdKey         = mkPreludeMiscIdUnique 229
+viewPIdKey        = mkPreludeMiscIdUnique 360
 
 -- type FieldPat = ...
 fieldPatIdKey :: Unique
@@ -2242,10 +2244,11 @@ cCallIdKey      = mkPreludeMiscIdUnique 300
 stdCallIdKey    = mkPreludeMiscIdUnique 301
 
 -- data Safety = ...
-unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
+unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
 unsafeIdKey     = mkPreludeMiscIdUnique 305
 safeIdKey       = mkPreludeMiscIdUnique 306
 threadsafeIdKey = mkPreludeMiscIdUnique 307
+interruptibleIdKey = mkPreludeMiscIdUnique 308
 
 -- data InlineSpec =
 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)