From fa32f755d61813a75ab8e5096ff86d505986e5d7 Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 21 Apr 2006 09:14:05 +0000 Subject: [PATCH] embedded haskelle example: query --- examples/query/Database.gf | 45 ++++++++++++++++++ examples/query/DatabaseEng.gf | 52 +++++++++++++++++++++ examples/query/Makefile | 15 ++++++ examples/query/README | 22 +++++++++ examples/query/UseDatabase.hs | 85 ++++++++++++++++++++++++++++++++++ src/GF/API/GrammarToHaskell.hs | 8 ++-- 6 files changed, 224 insertions(+), 3 deletions(-) create mode 100644 examples/query/Database.gf create mode 100644 examples/query/DatabaseEng.gf create mode 100644 examples/query/Makefile create mode 100644 examples/query/README create mode 100644 examples/query/UseDatabase.hs diff --git a/examples/query/Database.gf b/examples/query/Database.gf new file mode 100644 index 000000000..2385b8670 --- /dev/null +++ b/examples/query/Database.gf @@ -0,0 +1,45 @@ +-- abstract syntax of a small arithmetic query language + +abstract Database = { + +cat + Query ; S ; Q ; NP ; CN ; PN ; A1 ; A2 ; + +fun + QueryS : S -> Query ; + QueryQ : Q -> Query ; + + PredA1 : NP -> A1 -> S ; + + WhichA1 : CN -> A1 -> Q ; + WhichA2 : CN -> NP -> A2 -> Q ; + + ComplA2 : A2 -> NP -> A1 ; + UseInt : Int -> NP ; + + Every : CN -> NP ; + Some : CN -> NP ; + +-- lexicon + + Number : CN ; + Even,Odd,Prime : A1 ; + Equal,Greater,Smaller,Divisible : A2 ; + +-- replies + +cat Answer ; ListInt ; + +fun + Yes,No : Answer ; + None : Answer ; + List : ListInt -> Answer ; + One : Int -> ListInt ; + Cons : Int -> ListInt -> ListInt ; + +-- general moves +fun + Quit : Query ; + Bye : Answer ; + +} diff --git a/examples/query/DatabaseEng.gf b/examples/query/DatabaseEng.gf new file mode 100644 index 000000000..6af490678 --- /dev/null +++ b/examples/query/DatabaseEng.gf @@ -0,0 +1,52 @@ +--# -path=.:prelude + +concrete DatabaseEng of Database = open Prelude in { + +-- english query language + +flags lexer=literals ; unlexer=text ; + +-- concrete syntax; greatly simplified - just for test purposes + +lin + QueryS s = s ; + QueryQ q = q ; + + PredA1 np a = prefixSS "is" (cc2 np a) ; + + WhichA1 n a = ss ("which" ++ n.s ++ "are" ++ a.s) ; + WhichA2 n q a = ss ("which" ++ n.s ++ "are" ++ q.s ++ a.s) ; + + ComplA2 = cc2 ; + + Every A = ss ("every" ++ A.s) ; + Some A = ss ("some" ++ A.s) ; + UseInt n = n ; + + Number = ss "numbers" ; + + Even = ss "even" ; + Odd = ss "odd" ; + Prime = ss "prime" ; + Equal = ss ("equal" ++ "to") ; + Greater = ss ("greater" ++ "than") ; + Smaller = ss ("smaller" ++ "than") ; + Divisible = ss ("divisible" ++ "by") ; + +-- replies + +lin + Yes = ss "yes" ; + No = ss "no" ; + + None = ss "none" ; + List xs = xs ; + One n = n ; + Cons = cc2 ; + +-- general moves + +lin + Quit = ss "quit" ; + Bye = ss "bye" ; +} diff --git a/examples/query/Makefile b/examples/query/Makefile new file mode 100644 index 000000000..08ab63ae1 --- /dev/null +++ b/examples/query/Makefile @@ -0,0 +1,15 @@ +#GF=/users/mdstud/ltec06/GF +GF=/home/aarne/GF + +all: + make gf ; make ghc +ghc: + ghc -fglasgow-exts --make UseDatabase.hs -o query ; strip query +gf: + echo "pg -printer=haskell | wf GSyntax.hs ;; pm | wf database.gfcm" | gf DatabaseEng.gf +link: + ln -s $(GF)/src/GF + ln -s $(GF)/src/Transfer +# export GF_LIB_PATH=$(GF)/lib +clean: + rm *.hi *.o diff --git a/examples/query/README b/examples/query/README new file mode 100644 index 000000000..e1ce93098 --- /dev/null +++ b/examples/query/README @@ -0,0 +1,22 @@ +Aarne Ranta 6/5/2004; revised 10/5/2005 for GF 2.2, 21/4/2006 for GF 2.5. + +An example of database query system for Lab 2 of language technology course. + +To compile: + + Create a link to GF sources, by + + make link + + Create the file GSyntax.hs and the executable query + + make + +To run: + + ./query + +Examples: + + is 4567 prime + which numbers are prime diff --git a/examples/query/UseDatabase.hs b/examples/query/UseDatabase.hs new file mode 100644 index 000000000..cf90ae2a4 --- /dev/null +++ b/examples/query/UseDatabase.hs @@ -0,0 +1,85 @@ +module Main where + +import GSyntax +import GF.Embed.EmbedAPI + +import GF.Infra.UseIO + +-- to compile: make + +main :: IO () +main = do + gr <- file2grammar "database.gfcm" + loop gr + +loop :: MultiGrammar -> IO () +loop gr = do + putStrFlush "> " + s <- getLine + let ts = parse gr "DatabaseEng" "Query" s + case ts of + [t] -> case fg t of + GQuit -> putStrLnFlush (linearize gr "DatabaseEng" (gf GBye)) >> return () + t' -> case reply t' of + Left r -> (putStrLnFlush $ linearize gr "DatabaseEng" $ gf r) >> loop gr + Right xs -> print xs >> loop gr + [] -> putStrLnFlush "no parse" >> loop gr + _ -> do + putStrLnFlush "ambiguous parse:" +---- mapM_ (putStrLn . prGFTree) ts + loop gr + +-- the question-answer relation + +reply :: GQuery -> Either GAnswer [Ent] +reply (GQueryS s) = Left $ if (iS s) then GYes else GNo +reply (GQueryQ q) = case iQ q of + [] -> Left GNone + xs -> Right xs +{- much less efficient: + xs -> GList $ list xs + where + list [x] = GOne (GInt (show x)) + list (x:xs) = GCons (GInt (show x)) (list xs) +-} + +-- denotational semantics + +type Ent = Integer +type Prop = Bool + +domain :: [Ent] +domain = [0..10000] --- + +primes = sieve (drop 2 domain) where + sieve (p:x) = p : sieve [ n | n <- x, n `mod` p > 0 ] + sieve [] = [] + +iS :: GS -> Prop +iS (GPredA1 np ap) = iNP np (iA1 ap) + +iQ :: GQ -> [Ent] +iQ (GWhichA1 cn a) = [e | e <- iCN cn, iA1 a e] +iQ (GWhichA2 cn np a) = [e | e <- iCN cn, iNP np (\x -> iA2 a x e)] + +iA1 :: GA1 -> Ent -> Prop +iA1 (GComplA2 f q) = iNP q . iA2 f +iA1 GEven = even +iA1 GOdd = odd +iA1 GPrime = flip elem primes + +iA2 :: GA2 -> Ent -> Ent -> Prop +iA2 GEqual = (==) +iA2 GGreater = (>) +iA2 GSmaller = (<) +iA2 GDivisible = \x y -> y /= 0 && mod x y == 0 + + +iCN :: GCN -> [Ent] +iCN GNumber = domain + +iNP :: GNP -> (Ent -> Prop) -> Prop +iNP (GEvery cn) p = all p (iCN cn) +iNP (GSome cn) p = any p (iCN cn) +iNP (GUseInt (GInt n)) p = p n + diff --git a/src/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs index 81acdd47c..c3ca33247 100644 --- a/src/GF/API/GrammarToHaskell.hs +++ b/src/GF/API/GrammarToHaskell.hs @@ -50,9 +50,11 @@ haskPreamble = "class Gf a where gf :: a -> Trm", "class Fg a where fg :: Trm -> a", "", - predefInst "String" "K s", + predefInst "GString" "String" "K s", "", - predefInst "Int" "EInt s", + predefInst "GInt" "Integer" "EInt s", + "", + predefInst "GFloat" "Double" "EFloat s", "", "----------------------------------------------------", "-- below this line machine-generated", @@ -60,7 +62,7 @@ haskPreamble = "" ] -predefInst typ patt = let gtyp = gId typ in +predefInst gtyp typ patt = "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ "instance Gf" +++ gtyp +++ "where" ++++ " gf (" ++ gtyp +++ "s) =" +++ patt +++++