merged Gf and Fg classes in generated Haskell

2026-04-17 16:59:34 -06:00 · 2007-12-20 15:11:18 +00:00
parent d88071c37c
commit d46f4c49e1
9 changed files with 42 additions and 104 deletions
--- 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

--- a/examples/tutorial/embedded/Makefile_gfcc
+++ b/examples/tutorial/embedded/Makefile_gfcc
@@ -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
-
--- 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
--- a/examples/tutorial/embedded/TransferDefGFCC.hs
+++ b/examples/tutorial/embedded/TransferDefGFCC.hs
@@ -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 [] = []
--- 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"

--- a/examples/tutorial/embedded/TransferLoopGFCC.hs
+++ b/examples/tutorial/embedded/TransferLoopGFCC.hs
@@ -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"
-
--- a/lib/resource/Makefile
+++ b/lib/resource/Makefile
@@ -207,6 +207,16 @@ gf3present:
 #	$(GFNewPresC) -path=present:prelude:api:api/toplevel api/toplevel/OverLangEng.gf
 #	mv api/toplevel/Over*.gfc api/Try*.gf? ../present

+gf3mathematical:
+	$(GFNew) mathematical/MathematicalEng.gf
+	$(GFNew) mathematical/MathematicalNor.gf
+	$(GFNew) mathematical/MathematicalGer.gf
+	$(GFNew) mathematical/MathematicalSpa.gf
+	$(GFNew) mathematical/MathematicalIta.gf
+	$(GFNew) mathematical/MathematicalFre.gf
+	$(GFNew) mathematical/MathematicalSwe.gf
+	$(GFNew) mathematical/MathematicalFin.gf
+	mv mathematical/*.gfc ../mathematical

 gf3langs:
 	mv ../present/LangSpa.gfo tmpLangSpa.gfo
--- 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..]]
--- 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