merged Gf and Fg classes in generated Haskell

8 files changed, 32 insertions, 104 deletions

diff --git a/examples/tutorial/embedded/Makefile b/examples/tutorial/embedded/Makefile
index 787c75e69..119d5d0fe 100644
--- a/examples/tutorial/embedded/Makefile
+++ b/examples/tutorial/embedded/Makefile
@@ -1,18 +1,11 @@
-all: gf hs run
-
-gf:
-	echo "pm | wf math.gfcm" | gf MathEng.gf MathFre.gf
-
-hs: gf
-	echo "pg -printer=haskell | wf GSyntax.hs" | gf math.gfcm
-
-run: hs
+all:
+	gfc --make -haskell MathEng.gf MathFre.gf
 	ghc --make -o ./math TransferLoop.hs
 	strip math
 
 clean: 
-	rm -f *.gfc *.gfr *.o *.hi
+	rm -f *.gfo *.o *.hi
 
 distclean:
-	rm -f GSyntax.hs math math.gfcm *.gfc *.gfr *.o *.hi
+	rm -f GSyntax.hs math Math.gfcc *.gfo *.o *.hi
 
diff --git a/examples/tutorial/embedded/Makefile_gfcc b/examples/tutorial/embedded/Makefile_gfcc
deleted file mode 100644
index 257128e60..000000000
--- a/examples/tutorial/embedded/Makefile_gfcc
+++ /dev/null
@@ -1,18 +0,0 @@
-all: gf hs run
-
-gf:
-	echo "pm -printer=gfcc | wf math.gfcc" | gf MathEng.gf MathFre.gf
-
-hs: gf
-	echo "pg -printer=gfcc_haskell | wf GSyntax.hs" | gf MathEng.gf MathFre.gf
-
-run: hs
-	ghc --make -o ./mathc TransferLoopGFCC.hs
-	strip mathc
-
-clean: 
-	rm -f *.gfc *.gfr *.o *.hi
-
-distclean:
-	rm -f GSyntax.hs math math.gfcc *.gfc *.gfr *.o *.hi
-
diff --git a/examples/tutorial/embedded/TransferDef.hs b/examples/tutorial/embedded/TransferDef.hs
index 4a86dc949..8be39107d 100644
--- a/examples/tutorial/embedded/TransferDef.hs
+++ b/examples/tutorial/embedded/TransferDef.hs
@@ -1,6 +1,6 @@
 module TransferDef where
 
-import GF.Embed.EmbedAPI (Tree)
+import GF.GFCC.API (Tree)
 import GSyntax
 
 transfer :: Tree -> Tree
diff --git a/examples/tutorial/embedded/TransferDefGFCC.hs b/examples/tutorial/embedded/TransferDefGFCC.hs
deleted file mode 100644
index 00bbd5b3a..000000000
--- a/examples/tutorial/embedded/TransferDefGFCC.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module TransferDefGFCC where
-
-import GF.GFCC.API (Tree)
-import GSyntax
-
-transfer :: Tree -> Tree
-transfer = gf . answer . fg
-
-answer :: GQuestion -> GAnswer
-answer p = case p of
-  GOdd x   -> test odd x
-  GEven x  -> test even x
-  GPrime x -> test prime x
-
-value :: GObject -> Int
-value e = case e of
-  GNumber (GInt i) -> fromInteger i
-
-test :: (Int -> Bool) -> GObject -> GAnswer
-test f x = if f (value x) then GYes else GNo
-
-prime :: Int -> Bool
-prime x = elem x primes where
-  primes = sieve [2 .. x]
-  sieve (p:xs) = p : sieve [ n | n <- xs, n `mod` p > 0 ]
-  sieve [] = []
diff --git a/examples/tutorial/embedded/TransferLoop.hs b/examples/tutorial/embedded/TransferLoop.hs
index 07b530f74..708578156 100644
--- a/examples/tutorial/embedded/TransferLoop.hs
+++ b/examples/tutorial/embedded/TransferLoop.hs
@@ -1,11 +1,11 @@
 module Main where
 
-import GF.Embed.EmbedAPI
+import GF.GFCC.API
 import TransferDef (transfer)
 
 main :: IO () 
 main = do
-  gr <- file2grammar "math.gfcm"
+  gr <- file2grammar "Math.gfcc"
   loop (translate transfer gr)
 
 loop :: (String -> String) -> IO ()
@@ -17,7 +17,7 @@ loop trans = do
 
 translate :: (Tree -> Tree) -> MultiGrammar -> String -> String
 translate tr gr = unlines . map transLine . lines where
-  transLine s = case parseAllLang gr (startCat gr) s of
+  transLine s = case parseAllLang gr "Question" s of
     (lg,t:_):_ -> linearize gr lg (tr t)
     _ -> "NO PARSE"
 
diff --git a/examples/tutorial/embedded/TransferLoopGFCC.hs b/examples/tutorial/embedded/TransferLoopGFCC.hs
deleted file mode 100644
index e76afb788..000000000
--- a/examples/tutorial/embedded/TransferLoopGFCC.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Main where
-
-import GF.GFCC.API
-import TransferDefGFCC (transfer)
-
-main :: IO () 
-main = do
-  gr <- file2grammar "math.gfcc"
-  loop (translate transfer gr)
-
-loop :: (String -> String) -> IO ()
-loop trans = do 
-  s <- getLine
-  if s == "quit" then putStrLn "bye" else do  
-    putStrLn $ trans s
-    loop trans
-
-translate :: (Tree -> Tree) -> MultiGrammar -> String -> String
-translate tr gr = unlines . map transLine . lines where
-  transLine s = case parseAllLang gr "Question" s of
-    (lg,t:_):_ -> linearize gr lg (tr t)
-    _ -> "NO PARSE"
-
diff --git a/src/GF/Devel/GFCCtoHaskell.hs b/src/GF/Devel/GFCCtoHaskell.hs
index 4b34d1123..f836413cc 100644
--- a/src/GF/Devel/GFCCtoHaskell.hs
+++ b/src/GF/Devel/GFCCtoHaskell.hs
@@ -29,13 +29,13 @@ import qualified Data.Map as Map
 -- | the main function
 grammar2haskell :: GFCC -> String
 grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $  
-  haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
+  haskPreamble ++ [datatypes gr', gfinstances gr']
     where gr' = hSkeleton gr
 
 grammar2haskellGADT :: GFCC -> String
 grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $  
   ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
-  haskPreamble ++ [datatypesGADT gr', gfinstances gr', fginstances gr']
+  haskPreamble ++ [datatypesGADT gr', gfinstances gr']
     where gr' = hSkeleton gr
 
 -- | by this you can prefix all identifiers with stg; the default is 'G'
@@ -47,13 +47,14 @@ haskPreamble =
   "module GSyntax where",
   "",
   "import GF.GFCC.DataGFCC",
-  "import GF.GFCC.Raw.AbsGFCCRaw",
+  "import GF.GFCC.AbsGFCC",
   "----------------------------------------------------",
   "-- automatic translation from GF to Haskell",
   "----------------------------------------------------",
   "", 
-  "class Gf a where gf :: a -> Exp",
-  "class Fg a where fg :: Exp -> a",
+  "class Gf a where",
+  "  gf :: a -> Exp",
+  "  fg :: Exp -> a",
   "",
   predefInst "GString" "String" "DTr [] (AS s) []",
   "",
@@ -70,8 +71,7 @@ haskPreamble =
 predefInst gtyp typ patt = 
   "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
   "instance Gf" +++ gtyp +++ "where" ++++
-  "  gf (" ++ gtyp +++ "s) =" +++ patt +++++
-  "instance Fg" +++ gtyp +++ "where" ++++
+  "  gf (" ++ gtyp +++ "s) =" +++ patt ++++
   "  fg t =" ++++
   "    case t of" ++++
   "     " +++ patt +++ " ->" +++ gtyp +++ "s" ++++
@@ -81,13 +81,12 @@ type OIdent = String
 
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
-datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
+datatypes, gfinstances :: (String,HSkeleton) -> String
 datatypes   = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
-gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
-fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
+gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g
 
-hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
-hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
+hDatatype  :: (OIdent, [(OIdent, [OIdent])]) -> String
+gfInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
 
 hDatatype ("Cn",_) = "" ---
 hDatatype (cat,[]) = ""
@@ -120,6 +119,7 @@ hDatatypeGADT (cat, rules)
         [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
   where t = "Tree" +++ gId cat ++ "_"
 
+gfInstance m crs = hInstance m crs ++++ fInstance m crs
 
 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
 hInstance m (cat,[]) = "" 
@@ -133,13 +133,12 @@ hInstance m (cat,rules)
 -- no show for GADTs
 --     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
  | otherwise =
-  "instance Gf" +++ gId cat +++ "where" ++
-  (if length rules == 1 then "" else "\n") +++
-  foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
+  "instance Gf" +++ gId cat +++ "where\n" ++
+  unlines [mkInst f xx | (f,xx) <- rules]
  where
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
-   mkInst f xx = let xx' = mkVars (length xx) in "gf " ++
+   mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
      (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
    mkVars n = ["x" ++ show i | i <- [1..n]]
@@ -150,14 +149,13 @@ hInstance m (cat,rules)
 ----fInstance m ("Cn",_) = "" ---
 fInstance m (cat,[]) = ""
 fInstance m (cat,rules) =
-  "instance Fg" +++ gId cat +++ "where" ++++
-  " fg t =" ++++
-  "  case t of" ++++
-  foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
-  "    _ -> error (\"no" +++ cat ++ " \" ++ show t)"
+  "  fg t =" ++++
+  "    case t of" ++++
+  unlines [mkInst f xx | (f,xx) <- rules] ++++
+  "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
    where
     mkInst f xx =
-     "    DTr [] (AC (CId \"" ++ f ++ "\")) " ++
+     "      DTr [] (AC (CId \"" ++ f ++ "\")) " ++
      "[" ++ prTList "," xx' ++ "]" +++
      "->" +++ mkRHS f xx'
        where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
diff --git a/src/Makefile b/src/Makefile
index 7c0273485..421409280 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -69,6 +69,10 @@ endif
 
 all: unix gfdoc $(BUILD_JAR) lib
 
+static: GHCFLAGS += -optl-static
+static: unix
+
+
 gf: unix
 
 unix: today opt