[project @ 2002-09-09 12:50:26 by simonpj]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsDecls.lhs

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 9160f4a..036a427 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -17,7 +17,8 @@ module HsDecls (
        DeprecDecl(..), DeprecTxt,
        hsDeclName, instDeclName, 
        tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
-       isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
+       isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl,
+       isTypeOrClassDecl, countTyClDecls,
        mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
        getClassDeclSysNames, conDetailsTys,
        collectRuleBndrSigTys
@@ -302,12 +303,19 @@ data TyClDecl name pat
                tcdSysNames :: ClassSysNames name,
                tcdLoc      :: SrcLoc
     }
+    -- a Core value binding (coming from 'external Core' input.)
+  | CoreDecl { tcdName      :: name,  
+               tcdType      :: HsType name,
+              tcdRhs       :: UfExpr name,
+              tcdLoc       :: SrcLoc
+    }
+
 \end{code}
 
 Simple classifiers
 
 \begin{code}
-isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+isIfaceSigDecl, isCoreDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
 
 isIfaceSigDecl (IfaceSig {}) = True
 isIfaceSigDecl other        = False
@@ -320,6 +328,16 @@ isDataDecl other       = False
 
 isClassDecl (ClassDecl {}) = True
 isClassDecl other         = False
+
+isTypeOrClassDecl (ClassDecl   {}) = True
+isTypeOrClassDecl (TyData      {}) = True
+isTypeOrClassDecl (TySynonym   {}) = True
+isTypeOrClassDecl (ForeignType {}) = True
+isTypeOrClassDecl other                   = False
+
+isCoreDecl (CoreDecl {}) = True
+isCoreDecl other        = False
+
 \end{code}
 
 Dealing with names
@@ -338,6 +356,7 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
 
 tyClDeclNames (TySynonym   {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 tyClDeclNames (IfaceSig    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
+tyClDeclNames (CoreDecl    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 
 tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
@@ -352,6 +371,7 @@ tyClDeclTyVars (TyData    {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (ForeignType {})                     = []
 tyClDeclTyVars (IfaceSig {})                = []
+tyClDeclTyVars (CoreDecl {})                = []
 
 
 --------------------------------
@@ -396,6 +416,11 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
        tcdType d1 == tcdType d2 && 
        tcdIdInfo d1 == tcdIdInfo d2
 
+  (==) d1@(CoreDecl {}) d2@(CoreDecl {})
+      = tcdName d1 == tcdName d2 && 
+       tcdType d1 == tcdType d2 && 
+       tcdRhs d1  == tcdRhs  d2
+
   (==) d1@(ForeignType {}) d2@(ForeignType {})
       = tcdName d1 == tcdName d2 && 
        tcdFoType d1 == tcdFoType d2
@@ -453,7 +478,7 @@ countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
 countTyClDecls decls 
  = (count isClassDecl     decls,
     count isSynDecl       decls,
-    count isIfaceSigDecl  decls,
+    count (\ x -> isIfaceSigDecl x || isCoreDecl x) decls,
     count isDataTy        decls,
     count isNewTy         decls) 
  where
@@ -470,9 +495,7 @@ instance (NamedThing name, Outputable name, Outputable pat)
 
     ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
        = getPprStyle $ \ sty ->
-          hsep [ if ifaceStyle sty then ppr var else ppr_var var,
-                 dcolon, ppr ty, pprHsIdInfo info
-               ]
+          hsep [ ppr_var var, dcolon, ppr ty, pprHsIdInfo info ]
 
     ppr (ForeignType {tcdName = tycon})
        = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
@@ -504,11 +527,14 @@ instance (NamedThing name, Outputable name, Outputable pat)
         top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
        ppr_sig sig = ppr sig <> semi
 
-       pp_methods = getPprStyle $ \ sty ->
-                    if ifaceStyle sty || isNothing methods
+       pp_methods = if isNothing methods
                        then empty
                        else ppr (fromJust methods)
         
+    ppr (CoreDecl {tcdName = var, tcdType = ty, tcdRhs = rhs})
+       = getPprStyle $ \ sty ->
+          hsep [ ppr_var var, dcolon, ppr ty, ppr rhs ]
+
 pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 
@@ -629,9 +655,7 @@ ppr_con_details con (InfixCon ty1 ty2)
 -- we don't distinguish between the two.  Hence when printing these for the
 -- user, we need to parenthesise infix constructor names.
 ppr_con_details con (VanillaCon tys)
-  = getPprStyle $ \ sty ->
-    hsep ((if ifaceStyle sty then ppr con else ppr_var con)
-         : map (ppr_bang) tys)
+  = hsep (ppr_var con : map (ppr_bang) tys)
 
 ppr_con_details con (RecCon fields)
   = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
@@ -677,13 +701,9 @@ instance (Outputable name, Outputable pat)
              => Outputable (InstDecl name pat) where
 
     ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
-      = getPprStyle $ \ sty ->
-        if ifaceStyle sty then
-           hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun]
-       else
-          vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
-                nest 4 (ppr uprags),
-                nest 4 (ppr binds) ]
+      = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
+             nest 4 (ppr uprags),
+             nest 4 (ppr binds) ]
       where
        pp_dfun = case maybe_dfun_name of
                    Just df -> ppr df
@@ -809,10 +829,10 @@ instance Outputable ForeignImport where
     char '"' <> pprCEntity header lib spec <> char '"'
     where
       pprCEntity header lib (CLabel lbl) = 
-        ptext SLIT("static") <+> ptext header <+> char '&' <>
+        ptext SLIT("static") <+> ftext header <+> char '&' <>
        pprLib lib <> ppr lbl
       pprCEntity header lib (CFunction (StaticTarget lbl)) = 
-        ptext SLIT("static") <+> ptext header <+> char '&' <>
+        ptext SLIT("static") <+> ftext header <+> char '&' <>
        pprLib lib <> ppr lbl
       pprCEntity header lib (CFunction (DynamicTarget)) = 
         ptext SLIT("dynamic")
@@ -885,7 +905,7 @@ instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
 instance (NamedThing name, Outputable name, Outputable pat)
              => Outputable (RuleDecl name pat) where
   ppr (HsRule name act ns lhs rhs loc)
-       = sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act,
+       = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
               pp_forall, ppr lhs, equals <+> ppr rhs,
                text "#-}" ]
        where
@@ -893,7 +913,7 @@ instance (NamedThing name, Outputable name, Outputable pat)
                    | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
 
   ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) 
-    = hsep [ doubleQuotes (ptext name), ppr act,
+    = hsep [ doubleQuotes (ftext name), ppr act,
           ptext SLIT("__forall") <+> braces (interppSP tpl_vars),
           ppr fn <+> sep (map (pprUfExpr parens) tpl_args),
           ptext SLIT("=") <+> ppr rhs
@@ -918,7 +938,7 @@ We use exported entities for things to deprecate.
 \begin{code}
 data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
 
-type DeprecTxt = FAST_STRING   -- reason/explanation for deprecation
+type DeprecTxt = FastString    -- reason/explanation for deprecation
 
 instance Outputable name => Outputable (DeprecDecl name) where
     ppr (Deprecation thing txt _)