Added support for list categories.

src/GF/Source/SourceToGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:29 $ 
+-- > CVS $Date: 2005/05/25 10:42:00 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.22 $
+-- > CVS $Revision: 1.23 $
 --
 -- based on the skeleton Haskell module generated by the BNF converter
 -----------------------------------------------------------------------------
@@ -36,6 +36,7 @@ import GF.Infra.Option
 
 import Control.Monad
 import Data.Char
+import Data.List (genericReplicate)
 
 -- based on the skeleton Haskell module generated by the BNF converter
 
@@ -48,6 +49,11 @@ transIdent :: Ident -> Err Ident
 transIdent x = case x of
   x  -> return x
 
+transName :: Name -> Err Ident
+transName n = case n of
+  IdentName i -> transIdent i
+  ListName  i -> transIdent (mkListId i)
+
 transGrammar :: Grammar -> Err G.SourceGrammar
 transGrammar x = case x of
   Gr moddefs  -> do
@@ -192,9 +198,7 @@ transIncluded x = case x of
 
 transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
 transAbsDef x = case x of
-  DefCat catdefs -> do
-    catdefs' <- mapM transCatDef catdefs
-    returnl [(cat, G.AbsCat (yes cont) nope) | (cat,cont) <- catdefs']
+  DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
   DefFun fundefs -> do
     fundefs' <- mapM transFunDef fundefs
     returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
@@ -229,10 +233,27 @@ transFlagDef :: FlagDef -> Err GO.Option
 transFlagDef x = case x of
   FlagDef f x  -> return $ GO.Opt (prIdent f,[prIdent x])
 
-transCatDef :: CatDef -> Err (Ident, G.Context)
+-- | Cat definitions can also return some fun defs
+--   if it is a list category definition
+transCatDef :: CatDef -> Err [(Ident, G.Info)]
 transCatDef x = case x of
-  CatDef id ddecls  -> liftM2 (,) (transIdent id) 
-                                  (mapM transDDecl ddecls >>= return . concat)
+  SimpleCatDef id ddecls        -> liftM (:[]) $ cat id ddecls
+  ListCatDef id ddecls          -> listCat id ddecls 0
+  ListSizeCatDef id ddecls size -> listCat id ddecls size
+ where cat id ddecls = do
+		       i <- transIdent id
+		       cont <- liftM concat $ mapM transDDecl ddecls
+		       return (i, G.AbsCat (yes cont) nope)
+       listCat id ddecls size = do
+				let li = mkListId id
+				catd <- cat li ddecls
+				let cd = M.mkDecl (G.Vr id)
+				    lc = G.Vr li
+				    niltyp = M.mkProdSimple (genericReplicate size cd) lc
+				    nilfund = (mkBaseId id, G.AbsFun (yes niltyp) nope)
+				    constyp = M.mkProdSimple [cd, M.mkDecl lc] lc
+				    consfund = (mkConsId id, G.AbsFun (yes constyp) nope)
+				return [catd,nilfund,consfund]
 
 transFunDef :: FunDef -> Err ([Ident], G.Type)
 transFunDef x = case x of
@@ -302,27 +323,27 @@ transCncDef x = case x of
 
 transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
 transPrintDef x = case x of
-  PrintDef id exp  -> do
-    (ids,e) <- liftM2 (,) (mapM transIdent id) (transExp exp)
+  PrintDef ids exp  -> do
+    (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
     return $ [(i,e) | i <- ids]
 
 getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
 getDefsGen d = case d of
   DDecl ids t -> do
-    ids' <- mapM transIdent ids
+    ids' <- mapM transName ids
     t'   <- transExp t
     return [(i,(yes t', nope)) | i <- ids']
   DDef ids e -> do
-    ids' <- mapM transIdent ids
+    ids' <- mapM transName ids
     e'   <- transExp e
     return [(i,(nope, yes e')) | i <- ids']
   DFull ids t e -> do
-    ids' <- mapM transIdent ids
+    ids' <- mapM transName ids
     t'   <- transExp t
     e'   <- transExp e
     return [(i,(yes t', yes e')) | i <- ids']
   DPatt id patts e  -> do
-    id' <- transIdent id
+    id' <- transName id
     ps' <- mapM transPatt patts
     e'  <- transExp e
     return [(id',(nope, yes (G.Eqs [(ps',e')])))]
@@ -331,7 +352,7 @@ getDefsGen d = case d of
 getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
 getDefs d = case d of
   DPatt id patts e  -> do
-    id' <- transIdent id
+    id' <- transName id
     xs  <- mapM tryMakeVar patts
     e'  <- transExp e
     return [(id',(nope, yes (M.mkAbs xs e')))]
@@ -358,6 +379,8 @@ transExp x = case x of
   EInt n        -> return $ G.EInt $ fromInteger n
   EMeta         -> return $ M.meta $ M.int2meta 0
   EEmpty        -> return G.Empty
+  -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
+  EList i es    -> transExp $ foldl EApp (EIdent (mkListId i)) (exps2list es)
   EStrings []   -> return G.Empty
   EStrings str  -> return $ foldr1 G.C $ map G.K $ words str
   ERecord defs  -> erecord2term defs
@@ -416,6 +439,10 @@ transExp x = case x of
 
   _ -> Bad $ "translation not yet defined for" +++ printTree x ----
 
+exps2list :: Exps -> [Exp]
+exps2list NilExp = []
+exps2list (ConsExp e es) = e : exps2list es
+
 --- this is complicated: should we change Exp or G.Term ?
  
 erecord2term :: [LocDef] -> Err G.Term
@@ -615,3 +642,11 @@ termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
   abss xs t = case t of
     G.Abs x b -> abss (x:xs) b
     _ -> (reverse xs,t)
+
+mkListId,mkConsId,mkBaseId  :: Ident -> Ident
+mkListId = prefixId "List"
+mkConsId = prefixId "Cons"
+mkBaseId = prefixId "Base"
+
+prefixId :: String -> Ident -> Ident
+prefixId pref id = IC (pref ++ prIdent id)