Transfer: Changed BNFC's layout syntax resolver to add a semicolon at EOF if using top-level layout sytax. Changed transfer syntax to use this to force semicolon after imports when pretty printing transfer. transfer grammar printer now produces Transfer syntax, not core. It also imports prelude and includes Eq and Compos instances.

src/GF/API/GrammarToTransfer.hs

@@ -22,62 +22,73 @@ import GF.Grammar.Macros
 import GF.Infra.Modules
 import GF.Data.Operations
 
-import Transfer.Core.Abs as C
-import Transfer.Core.Print
+import Transfer.Syntax.Abs as S
+import Transfer.Syntax.Print
 
 
 -- | the main function
 grammar2transfer :: GFC.CanonGrammar -> String
-grammar2transfer gr = printTree $ C.Module [cats2cat cat tree cats, funs2tree cat tree funs]
+grammar2transfer gr = printTree $ S.Module imports decls
   where
-  cat = C.CIdent "Cat" -- FIXME
-  tree = C.CIdent "Tree" -- FIXME
+  cat = S.Ident "Cat" -- FIXME
+  tree = S.Ident "Tree" -- FIXME
   defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
   -- get category name and context
   cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs]
   -- get function name and type
   funs = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
   name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
-
-
+  imports = [Import (S.Ident "prelude")]
+  decls = [cats2cat cat tree cats, funs2tree cat tree funs] ++ instances tree
 
 
 -- | Create a declaration of the type of categories given a list
 --   of category names and their contexts.
-cats2cat :: CIdent -- ^ the name of the Cat type
-         -> CIdent -- ^ the name of the Tree type
+cats2cat :: S.Ident -- ^ the name of the Cat type
+         -> S.Ident -- ^ the name of the Tree type
          -> [(A.Ident,A.Context)] -> Decl
-cats2cat cat tree = C.DataDecl cat C.EType . map (uncurry catCons)
+cats2cat cat tree = S.DataDecl cat S.EType . map (uncurry catCons)
   where
-  catCons i c = C.ConsDecl (id2id i) (catConsType c)
-  catConsType = foldr pi (C.EVar cat)
-  pi (i,x) t = C.EPi (id2pv i) (addTree tree $ term2exp x) t
+  catCons i c = S.ConsDecl (id2id i) (catConsType c)
+  catConsType = foldr pi (S.EVar cat)
+  pi (i,x) t = mkPi (id2pv i) (addTree tree $ term2exp x) t
 
-funs2tree :: CIdent -- ^ the name of the Cat type
-          -> CIdent -- ^ the name of the Tree type
+funs2tree :: S.Ident -- ^ the name of the Cat type
+          -> S.Ident -- ^ the name of the Tree type
           -> [(A.Ident,A.Type)] -> Decl
 funs2tree cat tree = 
-    C.DataDecl tree (C.EPi C.PVWild (EVar cat) C.EType) . map (uncurry funCons)
+    S.DataDecl tree (S.EPiNoVar (S.EVar cat) S.EType) . map (uncurry funCons)
   where 
-  funCons i t = C.ConsDecl (id2id i) (addTree tree $ term2exp t)
+  funCons i t = S.ConsDecl (id2id i) (addTree tree $ term2exp t)
 
-term2exp :: A.Term -> C.Exp
+term2exp :: A.Term -> S.Exp
 term2exp t = case t of
-  A.Vr i         -> C.EVar (id2id i)
-  A.App t1 t2    -> C.EApp (term2exp t1) (term2exp t2)
-  A.Abs i t1     -> C.EAbs (id2pv i) (term2exp t1)
-  A.Prod i t1 t2 -> C.EPi (id2pv i) (term2exp t1) (term2exp t2)
-  A.Q m i        -> C.EVar (id2id i)
+  A.Vr i         -> S.EVar (id2id i)
+  A.App t1 t2    -> S.EApp (term2exp t1) (term2exp t2)
+  A.Abs i t1     -> S.EAbs (id2pv i) (term2exp t1)
+  A.Prod i t1 t2 -> mkPi (id2pv i) (term2exp t1) (term2exp t2)
+  A.Q m i        -> S.EVar (id2id i)
   _ -> error $ "term2exp: can't handle " ++ show t
 
-id2id :: A.Ident -> C.CIdent
-id2id = CIdent . symid
+mkPi :: S.VarOrWild -> S.Exp -> S.Exp -> S.Exp 
+mkPi VWild t e = S.EPiNoVar t e
+mkPi v     t e = S.EPi v t e
 
-id2pv :: A.Ident -> PatternVariable
-id2pv = C.PVVar . id2id
+id2id :: A.Ident -> S.Ident
+id2id = S.Ident . symid
+
+id2pv :: A.Ident -> S.VarOrWild
+id2pv i = case symid i of
+                       "h_" -> S.VWild -- FIXME: hacky?
+                       x    -> S.VVar (S.Ident x)
 
 -- FIXME: I think this is not general enoguh.
-addTree :: CIdent -> C.Exp -> C.Exp
+addTree :: S.Ident -> S.Exp -> S.Exp
 addTree tree x = case x of
-  C.EPi i t e -> C.EPi i (addTree tree t) (addTree tree e)
-  e -> C.EApp (C.EVar tree) e
+  S.EPi i t e -> S.EPi i (addTree tree t) (addTree tree e)
+  S.EPiNoVar t e -> S.EPiNoVar (addTree tree t) (addTree tree e)
+  e -> S.EApp (S.EVar tree) e
+
+instances :: S.Ident -> [S.Decl]
+instances tree = [DeriveDecl (S.Ident "Eq") tree, 
+                  DeriveDecl (S.Ident "Compos") tree]

src/Transfer/Syntax/Doc.tex

@@ -93,7 +93,6 @@ All other symbols are terminals.\\
 
 \begin{tabular}{lll}
 {\nonterminal{ListImport}} & {\arrow}  &{\emptyP} \\
- & {\delimit}  &{\nonterminal{Import}}  \\
  & {\delimit}  &{\nonterminal{Import}} {\terminal{;}} {\nonterminal{ListImport}}  \\
 \end{tabular}\\
 
@@ -106,7 +105,6 @@ All other symbols are terminals.\\
 
 \begin{tabular}{lll}
 {\nonterminal{ListDecl}} & {\arrow}  &{\emptyP} \\
- & {\delimit}  &{\nonterminal{Decl}}  \\
  & {\delimit}  &{\nonterminal{Decl}} {\terminal{;}} {\nonterminal{ListDecl}}  \\
 \end{tabular}\\
 

src/Transfer/Syntax/Layout.hs

@@ -105,10 +105,17 @@ resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]
   -- Nothing to see here, move along.
   res _ st (t:ts)  = moveAlong st [t] ts
 
-  -- We are at EOF, close all open implicit non-top-level layout blocks.
-  res (Just t) st [] = 
-        addTokens (position t) [layoutClose | Implicit n <- st, 
-                                              not (tl && n == 1)] []
+  -- At EOF: skip explicit blocks.
+  res (Just t) (Explicit:bs) [] | null bs = []
+                                | otherwise = res (Just t) bs []
+
+  -- If we are using top-level layout, insert a semicolon after the last token
+  res (Just t) [Implicit n] [] = addToken (nextPos t) layoutSep []
+
+  -- At EOF in an implicit, non-top-level block: close the block
+  res (Just t) (Implicit n:bs) [] =
+     let c = addToken (nextPos t) layoutClose []
+      in moveAlong bs c []
 
   -- This should only happen if the input is empty.
   res Nothing st [] = []

src/Transfer/Syntax/Par.y

@@ -78,7 +78,7 @@ Integer :: { Integer } : L_integ  { (read $1) :: Integer }
 Double  :: { Double }  : L_doubl  { (read $1) :: Double }
 
 Module :: { Module }
-Module : ListImport ListDecl { Module $1 $2 } 
+Module : ListImport ListDecl { Module (reverse $1) (reverse $2) } 
 
 
 Import :: { Import }
@@ -87,8 +87,7 @@ Import : 'import' Ident { Import $2 }
 
 ListImport :: { [Import] }
 ListImport : {- empty -} { [] } 
-  | Import { (:[]) $1 }
-  | Import ';' ListImport { (:) $1 $3 }
+  | ListImport Import ';' { flip (:) $1 $2 }
 
 
 Decl :: { Decl }
@@ -100,8 +99,7 @@ Decl : 'data' Ident ':' Exp 'where' '{' ListConsDecl '}' { DataDecl $2 $4 $7 }
 
 ListDecl :: { [Decl] }
 ListDecl : {- empty -} { [] } 
-  | Decl { (:[]) $1 }
-  | Decl ';' ListDecl { (:) $1 $3 }
+  | ListDecl Decl ';' { flip (:) $1 $2 }
 
 
 ConsDecl :: { ConsDecl }

src/Transfer/Syntax/Print.hs

@@ -154,12 +154,10 @@ instance Print (Tree c) where
 instance Print [Import] where
   prt _ es = case es of
    [] -> (concatD [])
-   [x] -> (concatD [prt 0 x])
    x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
 instance Print [Decl] where
   prt _ es = case es of
    [] -> (concatD [])
-   [x] -> (concatD [prt 0 x])
    x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
 instance Print [ConsDecl] where
   prt _ es = case es of

src/Transfer/Syntax/Syntax.cf

@@ -10,13 +10,16 @@ comment "{-" "-}" ;
 Module. Module ::= [Import] [Decl] ;
 
 Import. Import ::= "import" Ident ;
-separator Import ";" ;
+-- FIXME: this is terminator to ensure that the pretty printer
+-- produces a semicolon after the last import. This could cause
+-- problems in a program which only does imports and uses layout syntax.
+terminator Import ";" ;
 
 DataDecl.     Decl ::= "data" Ident ":" Exp "where" "{" [ConsDecl] "}" ;
 TypeDecl.     Decl ::= Ident ":" Exp ;
 ValueDecl.    Decl ::= Ident [Pattern] Guard "=" Exp ;
 DeriveDecl.   Decl ::= "derive" Ident Ident ;
-separator Decl ";" ;
+terminator Decl ";" ;
 
 ConsDecl. ConsDecl ::= Ident ":" Exp ;
 separator ConsDecl ";" ;