From 836583cface32260bf9e6480892a5fa22e8a9084 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Tue, 4 Dec 2007 11:18:55 +0000
Subject: [PATCH] some missing cases in SourceToGF

---
 src/GF/Devel/Grammar/Macros.hs     | 22 ++++++++++++++++++++++
 src/GF/Devel/Grammar/SourceToGF.hs |  6 +++---
 src/GF/Devel/TestGF3.hs            |  5 +++--
 3 files changed, 28 insertions(+), 5 deletions(-)

diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs
index 12fa1e747..9af5e7ec9 100644
--- a/src/GF/Devel/Grammar/Macros.hs
+++ b/src/GF/Devel/Grammar/Macros.hs
@@ -39,6 +39,28 @@ mkApp = foldl App
 mkAbs :: [Ident] -> Term -> Term
 mkAbs xs t = foldr Abs t xs
 
+mkCTable :: [Ident] -> Term -> Term
+mkCTable ids v = foldr ccase v ids where 
+  ccase x t = T TRaw [(PV x,t)]
+
+tuple2record :: [Term] -> [Assign]
+tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
+
+tuple2recordType :: [Term] -> [Labelling]
+tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+tuple2recordPatt :: [Patt] -> [(Label,Patt)]
+tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+tupleLabel :: Int -> Label
+tupleLabel i = LIdent $ "p" ++ show i
+
+assign :: Label -> Term -> Assign
+assign l t = (l,(Nothing,t))
+
+assignT :: Label -> Type -> Term -> Assign
+assignT l a t = (l,(Just a,t))
+
 mkDecl :: Term -> Decl
 mkDecl typ = (wildIdent, typ)
 
diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs
index cefc1192c..0ad966648 100644
--- a/src/GF/Devel/Grammar/SourceToGF.hs
+++ b/src/GF/Devel/Grammar/SourceToGF.hs
@@ -404,7 +404,7 @@ transExp x = case x of
           G.Typed _ t -> G.TTyped t
           _ -> G.TRaw 
     return $ G.S (G.T annot cases') exp'
-----  ECTable binds exp  -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
+  ECTable binds exp  -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
 
   EVariants exps    -> liftM  G.FV $ mapM transExp exps
   EPre exp alts     -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
@@ -507,8 +507,8 @@ transPatt x = case x of
     let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
         ls = map LPIdent $ concat lss
     liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
-----  PTup pcs -> 
-----    liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
+  PTup pcs -> 
+    liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
   PQ id0 id  -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
   PQC id0 id patts  -> 
     liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
diff --git a/src/GF/Devel/TestGF3.hs b/src/GF/Devel/TestGF3.hs
index 3f3b9f358..d8aad44d1 100644
--- a/src/GF/Devel/TestGF3.hs
+++ b/src/GF/Devel/TestGF3.hs
@@ -3,13 +3,14 @@ module Main where
 import GF.Devel.Grammar.LexGF
 import GF.Devel.Grammar.ParGF
 ---- import GF.Devel.Grammar.PrintGF
-import GF.Devel.Grammar.AbsGF
+import GF.Devel.Grammar.Modules
 
 import GF.Devel.Grammar.SourceToGF
 
 import qualified GF.Devel.Grammar.ErrM as GErr ----
 import GF.Data.Operations
 
+import Data.Map
 import System (getArgs)
 
 main = do
@@ -23,7 +24,7 @@ main = do
 compile g = do
   let eg = transGrammar g
   case eg of
-    Ok _ -> putStrLn "OK"
+    Ok gr -> print (length (assocs (gfmodules gr))) >> putStrLn "OK"
     Bad s -> putStrLn s
   return ()