Revive External Core parser

[ghc-hetmet.git] / utils / ext-core / Core.hs

diff --git a/utils/ext-core/Core.hs b/utils/ext-core/Core.hs
index 2f94f80..46e8185 100644 (file)
--- a/utils/ext-core/Core.hs
+++ b/utils/ext-core/Core.hs
@@ -3,15 +3,18 @@ module Core where
 import List (elemIndex)
 
 data Module 
- = Module Mname [Tdef] [Vdefg]
+ = Module AnMname [Tdef] [Vdefg]
 
 data Tdef 
   = Data (Qual Tcon) [Tbind] [Cdef]
-  | Newtype (Qual Tcon) [Tbind] (Maybe Ty)
+  | Newtype (Qual Tcon) [Tbind] Axiom (Maybe Ty)
 
 data Cdef 
   = Constr (Qual Dcon) [Tbind] [Ty]
 
+-- Newtype coercion
+type Axiom = (Qual Tcon, Kind)
+
 data Vdefg 
   = Rec [Vdef]
   | Nonrec Vdef
@@ -26,8 +29,8 @@ data Exp
   | Appt Exp Ty
   | Lam Bind Exp         
   | Let Vdefg Exp
-  | Case Exp Vbind [Alt] {- non-empty list -}
-  | Coerce Ty Exp 
+  | Case Exp Vbind Ty [Alt] {- non-empty list -}
+  | Cast Exp Ty
   | Note String Exp
   | External String Ty
 
@@ -54,16 +57,29 @@ data Kind
   | Kunlifted
   | Kopen
   | Karrow Kind Kind
-  deriving (Eq)
-
-data Lit 
-  = Lint Integer Ty
-  | Lrational Rational Ty
-  | Lchar Char Ty
-  | Lstring String Ty
-  deriving (Eq)  -- with nearlyEqualTy 
-
-type Mname = Id
+  | Keq Ty Ty
+
+data Lit = Literal CoreLit Ty
+  deriving Eq   -- with nearlyEqualTy 
+
+data CoreLit = Lint Integer
+  | Lrational Rational
+  | Lchar Char
+  | Lstring String 
+  deriving Eq
+
+-- Right now we represent module names as triples:
+-- (package name, hierarchical names, leaf name)
+-- An alternative to this would be to flatten the
+-- module namespace, either when printing out
+-- Core or (probably preferably) in a 
+-- preprocessor.
+-- The empty module name (as in an unqualified name)
+-- is represented as Nothing.
+
+type Mname = Maybe AnMname
+type AnMname = (Pname, [Id], Id)
+type Pname = Id
 type Var = Id
 type Tvar = Id
 type Tcon = Id
@@ -71,8 +87,25 @@ type Dcon = Id
 
 type Qual t = (Mname,t)
 
+qual :: AnMname -> t -> Qual t
+qual mn t = (Just mn, t)
+
+unqual :: t -> Qual t
+unqual = (,) Nothing
+
 type Id = String
 
+eqKind :: Kind -> Kind -> Bool
+eqKind Klifted Klifted = True
+eqKind Kunlifted Kunlifted = True
+eqKind Kopen Kopen = True
+eqKind (Karrow k1 k2) (Karrow l1 l2) = k1 `eqKind` l1
+                                   &&  k2 `eqKind` l2
+eqKind _ _ = False -- no Keq kind is ever equal to any other...
+                   -- maybe ok for now?
+
+--- tjc: I haven't looked at the rest of this file. ---
+
 {- Doesn't expand out fully applied newtype synonyms
    (for which an environment is needed). -}
 nearlyEqualTy t1 t2 =  eqTy [] [] t1 t2 
@@ -85,39 +118,53 @@ nearlyEqualTy t1 t2 =  eqTy [] [] t1 t2
         eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
              eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
         eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
-             tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2 
+             tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2 
        eqTy _ _ _ _ = False
 instance Eq Ty where (==) = nearlyEqualTy
 
 
 subKindOf :: Kind -> Kind -> Bool
 _ `subKindOf` Kopen = True
-k1 `subKindOf` k2 = k1 == k2  -- doesn't worry about higher kinds
-
-instance Ord Kind where (<=) = subKindOf
+k1 `subKindOf` k2 = k1 `eqKind` k2  -- doesn't worry about higher kinds
 
 baseKind :: Kind -> Bool
 baseKind (Karrow _ _ ) = False
 baseKind _ = True
 
-primMname = "PrelGHC"
+isPrimVar (Just mn,_) = mn == primMname
+isPrimVar _ = False
+
+primMname = mkBaseMname "Prim"
+errMname  = mkBaseMname "Err"
+mkBaseMname :: Id -> AnMname
+mkBaseMname mn = (basePkg, ghcPrefix, mn)
+basePkg = "base"
+mainPkg = "main"
+ghcPrefix = ["GHC"]
+mainPrefix = []
+baseMname = mkBaseMname "Base"
+mainVar = qual mainMname "main"
+mainMname = (mainPkg, mainPrefix, "Main")
 
 tcArrow :: Qual Tcon
-tcArrow = (primMname, "ZLzmzgZR")
+tcArrow = (Just primMname, "ZLzmzgZR")
 
 tArrow :: Ty -> Ty -> Ty
 tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
 
+
 ktArrow :: Kind
 ktArrow = Karrow Kopen (Karrow Kopen Klifted)
 
 {- Unboxed tuples -}
 
+-- tjc: not sure whether anything that follows is right
+
 maxUtuple :: Int
 maxUtuple = 100
 
 tcUtuple :: Int -> Qual Tcon
-tcUtuple n = (primMname,"Z"++ (show n) ++ "H")
+tcUtuple n = (Just primMname,"Z"++ (show n) ++ "H")
 
 ktUtuple :: Int -> Kind
 ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
@@ -131,7 +178,7 @@ isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
 isUtupleTy _ = False
 
 dcUtuple :: Int -> Qual Dcon
-dcUtuple n = (primMname,"ZdwZ" ++ (show n) ++ "H")
+dcUtuple n = (Just primMname,"ZdwZ" ++ (show n) ++ "H")
 
 isUtupleDc :: Qual Dcon -> Bool
 isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]