Putting def definitions in place.

src/GF/Source/AbsGF.hs

@@ -2,12 +2,10 @@ module AbsGF where
 
 import Ident --H
 
--- Haskell module generated by the BNF converter, except for --H
+-- Haskell module generated by the BNF converter, except --H
 
 -- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
-
 newtype LString = LString String deriving (Eq,Ord,Show)
-
 data Grammar =
    Gr [ModDef]
   deriving (Eq,Ord,Show)
@@ -66,7 +64,7 @@ data TopDef =
    DefCat [CatDef]
  | DefFun [FunDef]
  | DefDef [Def]
- | DefData [ParDef]
+ | DefData [DataDef]
  | DefTrans [FlagDef]
  | DefPar [ParDef]
  | DefOper [Def]
@@ -89,6 +87,15 @@ data FunDef =
    FunDef [Ident] Exp
   deriving (Eq,Ord,Show)
 
+data DataDef =
+   DataDef Ident [DataConstr]
+  deriving (Eq,Ord,Show)
+
+data DataConstr =
+   DataId Ident
+ | DataQId Ident Ident
+  deriving (Eq,Ord,Show)
+
 data ParDef =
    ParDef Ident [ParConstr]
  | ParDefIndir Ident Ident

src/GF/Source/GrammarToSource.hs

@@ -41,8 +41,13 @@ mkTopDefs ds = ds
 
 trAnyDef :: (Ident,Info) -> [P.TopDef]
 trAnyDef (i,info) = let i' = tri i in case info of
-  AbsCat (Yes co) _ -> [P.DefCat [P.CatDef i' (map trDecl co)]]
-  AbsFun (Yes ty) _ -> [P.DefFun [P.FunDef [i'] (trt ty)]]
+  AbsCat (Yes co) pd -> [P.DefCat [P.CatDef i' (map trDecl co)]] ++ case pd of
+    Yes fs -> [P.DefData [P.DataDef i' [P.DataQId (tri m) (tri c) | QC m c <- fs]]]
+    _ -> []
+  AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
+    Yes EData -> [] -- keep this information in data defs only
+    Yes t -> [P.DefDef [P.DDef [i'] (trt t)]]
+    _ -> []
   AbsFun (May b)  _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
   ---- don't destroy definitions!
 
@@ -85,8 +90,6 @@ trt trm = case trm of
     Vr s -> P.EIdent $ tri s
     Cn s -> P.ECons $ tri s
     Con s -> P.EConstr $ tri s
-----    ConAt id typ -> P.EConAt (tri id) (trt typ)
-
     Sort s -> P.ESort $ case s of
       "Type" -> P.Sort_Type
       "PType" -> P.Sort_PType
@@ -95,13 +98,9 @@ trt trm = case trm of
       "Strs" -> P.Sort_Strs
       _ -> error $ "not yet sort " +++ show trm ----
 
-
     App c a -> P.EApp (trt c) (trt a)
     Abs x b -> P.EAbstr [trb x] (trt b)
-
-----    Eqs pts -> "fn" +++ prCurlyList [prtBranchOld pst | pst <- pts] ---
-----    ECase e bs -> "case" +++ prt e +++ "of" +++ prCurlyList (map prtBranch bs) 
-
+    Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
     Meta m  -> P.EMeta
     Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
     Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)

src/GF/Source/LexGF.hs

@@ -1,3 +1,4 @@
+
 module LexGF where
 
 import Alex

src/GF/Source/PrintGF.hs

@@ -165,7 +165,7 @@ instance Print TopDef where
    DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs])
    DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs])
    DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs])
-   DefData pardefs -> prPrec i 0 (concat [["data"] , prt 0 pardefs])
+   DefData datadefs -> prPrec i 0 (concat [["data"] , prt 0 datadefs])
    DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs])
    DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs])
    DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs])
@@ -199,6 +199,24 @@ instance Print FunDef where
    [x] -> (concat [prt 0 x , [";"]])
    x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
 
+instance Print DataDef where
+  prt i e = case e of
+   DataDef id dataconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 dataconstrs])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print DataConstr where
+  prt i e = case e of
+   DataId id -> prPrec i 0 (concat [prt 0 id])
+   DataQId id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
+
 instance Print ParDef where
   prt i e = case e of
    ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs])

src/GF/Source/SkelGF.hs

@@ -3,7 +3,6 @@ module SkelGF where
 -- Haskell module generated by the BNF converter
 
 import AbsGF
-import Ident
 import ErrM
 type Result = Err String
 
@@ -12,7 +11,7 @@ failure x = Bad $ "Undefined case: " ++ show x
 
 transIdent :: Ident -> Result
 transIdent x = case x of
-  _  -> failure x
+  Ident str  -> failure x
 
 
 transLString :: LString -> Result
@@ -88,7 +87,7 @@ transTopDef x = case x of
   DefCat catdefs  -> failure x
   DefFun fundefs  -> failure x
   DefDef defs  -> failure x
-  DefData pardefs  -> failure x
+  DefData datadefs  -> failure x
   DefTrans flagdefs  -> failure x
   DefPar pardefs  -> failure x
   DefOper defs  -> failure x
@@ -113,6 +112,17 @@ transFunDef x = case x of
   FunDef ids exp  -> failure x
 
 
+transDataDef :: DataDef -> Result
+transDataDef x = case x of
+  DataDef id dataconstrs  -> failure x
+
+
+transDataConstr :: DataConstr -> Result
+transDataConstr x = case x of
+  DataId id  -> failure x
+  DataQId id0 id  -> failure x
+
+
 transParDef :: ParDef -> Result
 transParDef x = case x of
   ParDef id parconstrs  -> failure x

src/GF/Source/SourceToGrammar.hs

@@ -144,13 +144,24 @@ transAbsDef x = case x of
   DefDef defs  -> do
     defs' <- liftM concat $ mapM getDefsGen defs
     returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs']
-  DefData _ -> returnl [] ----
+  DefData ds -> do
+    ds' <- mapM transDataDef ds
+    returnl $ 
+      [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
+      [(f, G.AbsFun nope (yes G.EData))  | (_,fs) <- ds', tf <- fs, f <- funs tf]
   DefTrans defs  -> do
     let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs]
     defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals)
     returnl [(c, G.AbsTrans f) | (c,f) <- defs']
   DefFlag defs -> liftM Right $ mapM transFlagDef defs
   _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
+ where
+   -- to get data constructors as terms
+   funs t = case t of
+     G.Cn f -> [f]
+     G.Q _ f -> [f]
+     G.QC _ f -> [f]
+     _ -> []
 
 returnl :: a -> Err (Either a b)
 returnl = return . Left
@@ -168,6 +179,14 @@ transFunDef :: FunDef -> Err ([Ident], G.Type)
 transFunDef x = case x of
   FunDef ids typ  -> liftM2 (,) (mapM transIdent ids) (transExp typ)
 
+transDataDef :: DataDef -> Err (Ident,[G.Term])
+transDataDef x = case x of
+  DataDef id ds  -> liftM2 (,) (transIdent id) (mapM transData ds) 
+ where
+   transData d = case d of
+     DataId id  -> liftM G.Cn $ transIdent id
+     DataQId id0 id  -> liftM2 G.QC (transIdent id0) (transIdent id)
+
 transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
 transResDef x = case x of
   DefPar pardefs -> do
@@ -327,6 +346,8 @@ transExp x = case x of
   ELString (LString str) -> return $ G.K str 
   ELin id -> liftM G.LiT $ transIdent id
 
+  EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
+
   _ -> Bad $ "translation not yet defined for" +++ printTree x ----
 
 --- this is complicated: should we change Exp or G.Term ?
@@ -421,6 +442,10 @@ transCase (Case pattalts exp) = do
   exp'  <- transExp exp  
   return [(p,exp') | p <- patts]
 
+transEquation :: Equation -> Err G.Equation
+transEquation x = case x of
+  Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp)
+
 transAltern :: Altern -> Err (G.Term, G.Term)
 transAltern x = case x of
   Alt exp0 exp  -> liftM2 (,) (transExp exp0) (transExp exp)

src/GF/Source/TestGF.hs

@@ -6,15 +6,18 @@ import ParGF
 import SkelGF
 import PrintGF
 import AbsGF
+
 import ErrM
 
 type ParseFun a = [Token] -> Err a
 
+myLLexer = myLexer
+
 runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO()
 runFile p f = readFile f >>= run p
 
 run :: (Print a, Show a) => ParseFun a -> String -> IO()
-run p s = case (p (myLexer s)) of
+run p s = case (p (myLLexer s)) of
            Bad s    -> do  putStrLn "\nParse Failed...\n"
                            putStrLn s
            Ok  tree -> do putStrLn "\nParse Successful!"