modernized parser in EmbedAPI

2 files changed, 138 insertions, 0 deletions

diff --git a/examples/tutorial/embedded/haskell/GSyntax.hs b/examples/tutorial/embedded/haskell/GSyntax.hs
new file mode 100644
index 000000000..28469e7da
--- /dev/null
+++ b/examples/tutorial/embedded/haskell/GSyntax.hs
@@ -0,0 +1,100 @@
+module GSyntax where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.PrGrammar
+import GF.Grammar.Macros
+import GF.Data.Operations
+----------------------------------------------------
+-- automatic translation from GF to Haskell
+----------------------------------------------------
+
+class Gf a where gf :: a -> Trm
+class Fg a where fg :: Trm -> a
+
+newtype GString = GString String  deriving Show
+
+instance Gf GString where
+  gf (GString s) = K s
+
+instance Fg GString where
+  fg t =
+    case termForm t of
+      Ok ([], K s ,[]) -> GString s
+      _ -> error ("no GString " ++ prt t)
+
+newtype GInt = GInt Integer  deriving Show
+
+instance Gf GInt where
+  gf (GInt s) = EInt s
+
+instance Fg GInt where
+  fg t =
+    case termForm t of
+      Ok ([], EInt s ,[]) -> GInt s
+      _ -> error ("no GInt " ++ prt t)
+
+newtype GFloat = GFloat Double  deriving Show
+
+instance Gf GFloat where
+  gf (GFloat s) = EFloat s
+
+instance Fg GFloat where
+  fg t =
+    case termForm t of
+      Ok ([], EFloat s ,[]) -> GFloat s
+      _ -> error ("no GFloat " ++ prt t)
+
+----------------------------------------------------
+-- below this line machine-generated
+----------------------------------------------------
+
+data GAnswer =
+   GYes 
+ | GNo 
+  deriving Show
+
+data GObject = GNumber GInt 
+  deriving Show
+
+data GQuestion =
+   GPrime GObject 
+ | GOdd GObject 
+ | GEven GObject 
+  deriving Show
+
+
+instance Gf GAnswer where
+ gf GYes = appqc "Math" "Yes" []
+ gf GNo = appqc "Math" "No" []
+
+instance Gf GObject where gf (GNumber x1) = appqc "Math" "Number" [gf x1]
+
+instance Gf GQuestion where
+ gf (GPrime x1) = appqc "Math" "Prime" [gf x1]
+ gf (GOdd x1) = appqc "Math" "Odd" [gf x1]
+ gf (GEven x1) = appqc "Math" "Even" [gf x1]
+
+
+instance Fg GAnswer where
+ fg t =
+  case termForm t of
+    Ok ([], Q (IC "Math") (IC "Yes"),[]) -> GYes 
+    Ok ([], Q (IC "Math") (IC "No"),[]) -> GNo 
+    _ -> error ("no Answer " ++ prt t)
+
+instance Fg GObject where
+ fg t =
+  case termForm t of
+    Ok ([], Q (IC "Math") (IC "Number"),[x1]) -> GNumber (fg x1)
+    _ -> error ("no Object " ++ prt t)
+
+instance Fg GQuestion where
+ fg t =
+  case termForm t of
+    Ok ([], Q (IC "Math") (IC "Prime"),[x1]) -> GPrime (fg x1)
+    Ok ([], Q (IC "Math") (IC "Odd"),[x1]) -> GOdd (fg x1)
+    Ok ([], Q (IC "Math") (IC "Even"),[x1]) -> GEven (fg x1)
+    _ -> error ("no Question " ++ prt t)
+
+
diff --git a/examples/tutorial/embedded/haskell/Run.hs b/examples/tutorial/embedded/haskell/Run.hs
new file mode 100644
index 000000000..c3fd87466
--- /dev/null
+++ b/examples/tutorial/embedded/haskell/Run.hs
@@ -0,0 +1,38 @@
+module Main where
+
+import GSyntax
+import GF.Embed.EmbedAPI
+
+main :: IO () 
+main = do
+  gr <- file2grammar "math.gfcm"
+  loop gr
+
+loop :: MultiGrammar -> IO ()
+loop gr = do
+  s <- getLine
+  interpret gr s
+  loop gr
+
+interpret :: MultiGrammar -> String -> IO ()
+interpret gr s = do
+  let ltss = parseAllLang gr "Question" s
+  case ltss of
+    [] ->  putStrLn "no parse"
+    (l,t:_):_ -> putStrLn $ linearize gr l $ gf $ answer $ fg t
+
+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 = (< 8) ----