summaryrefslogtreecommitdiff
path: root/old-examples/tutorial/embedded/haskell/GSyntax.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
commite9e80fc389365e24d4300d7d5390c7d833a96c50 (patch)
treef0b58473adaa670bd8fc52ada419d8cad470ee03 /old-examples/tutorial/embedded/haskell/GSyntax.hs
parentb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (diff)
changed names of resource-1.3; added a note on homepage on release
Diffstat (limited to 'old-examples/tutorial/embedded/haskell/GSyntax.hs')
-rw-r--r--old-examples/tutorial/embedded/haskell/GSyntax.hs100
1 files changed, 100 insertions, 0 deletions
diff --git a/old-examples/tutorial/embedded/haskell/GSyntax.hs b/old-examples/tutorial/embedded/haskell/GSyntax.hs
new file mode 100644
index 000000000..28469e7da
--- /dev/null
+++ b/old-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)
+
+