From f32307b39db77a937aa87b0cd455acc639665cd6 Mon Sep 17 00:00:00 2001 From: aarne Date: Sat, 5 Mar 2011 22:25:03 +0000 Subject: [PATCH] added composOp generation to haskell-gadt, and an example in examples/gadt-transfer --- examples/gadt-transfer/Foods.gf | 15 ++++++ examples/gadt-transfer/FoodsDut.gf | 58 ++++++++++++++++++++++ examples/gadt-transfer/FoodsEng.gf | 43 ++++++++++++++++ examples/gadt-transfer/Makefile | 4 ++ examples/gadt-transfer/README | 35 +++++++++++++ examples/gadt-transfer/VeryFoods.hs | 23 +++++++++ src/compiler/GF/Compile/PGFtoHaskell.hs | 65 +++++++++++++++++++++++-- 7 files changed, 239 insertions(+), 4 deletions(-) create mode 100644 examples/gadt-transfer/Foods.gf create mode 100644 examples/gadt-transfer/FoodsDut.gf create mode 100644 examples/gadt-transfer/FoodsEng.gf create mode 100644 examples/gadt-transfer/Makefile create mode 100644 examples/gadt-transfer/README create mode 100644 examples/gadt-transfer/VeryFoods.hs diff --git a/examples/gadt-transfer/Foods.gf b/examples/gadt-transfer/Foods.gf new file mode 100644 index 000000000..8ea02f39d --- /dev/null +++ b/examples/gadt-transfer/Foods.gf @@ -0,0 +1,15 @@ +-- (c) 2009 Aarne Ranta under LGPL + +abstract Foods = { + flags startcat = Comment ; + cat + Comment ; Item ; Kind ; Quality ; + fun + Pred : Item -> Quality -> Comment ; + This, That, These, Those : Kind -> Item ; + Mod : Quality -> Kind -> Kind ; + Wine, Cheese, Fish, Pizza : Kind ; + Very : Quality -> Quality ; + Fresh, Warm, Italian, + Expensive, Delicious, Boring : Quality ; +} diff --git a/examples/gadt-transfer/FoodsDut.gf b/examples/gadt-transfer/FoodsDut.gf new file mode 100644 index 000000000..d4855e5c6 --- /dev/null +++ b/examples/gadt-transfer/FoodsDut.gf @@ -0,0 +1,58 @@ +-- (c) 2009 Femke Johansson under LGPL + +concrete FoodsDut of Foods = { + + lincat + Comment = {s : Str}; + Quality = {s : AForm => Str}; + Kind = { s : Number => Str}; + Item = {s : Str ; n : Number}; + + lin + Pred item quality = + {s = item.s ++ copula ! item.n ++ quality.s ! APred}; + This = det Sg "deze"; + These = det Pl "deze"; + That = det Sg "die"; + Those = det Pl "die"; + + Mod quality kind = + {s = \\n => quality.s ! AAttr ++ kind.s ! n}; + Wine = regNoun "wijn"; + Cheese = noun "kaas" "kazen"; + Fish = noun "vis" "vissen"; + Pizza = noun "pizza" "pizza's"; + + Very a = {s = \\f => "erg" ++ a.s ! f}; + + Fresh = regadj "vers"; + Warm = regadj "warm"; + Italian = regadj "Italiaans"; + Expensive = adj "duur" "dure"; + Delicious = regadj "lekker"; + Boring = regadj "saai"; + + param + Number = Sg | Pl; + AForm = APred | AAttr; + + oper + det : Number -> Str -> + {s : Number => Str} -> {s : Str ; n: Number} = + \n,det,noun -> {s = det ++ noun.s ! n ; n=n}; + + noun : Str -> Str -> {s : Number => Str} = + \man,men -> {s = table {Sg => man; Pl => men}}; + + regNoun : Str -> {s : Number => Str} = + \wijn -> noun wijn (wijn + "en"); + + regadj : Str -> {s : AForm => Str} = + \koud -> adj koud (koud+"e"); + + adj : Str -> Str -> {s : AForm => Str} = + \duur, dure -> {s = table {APred => duur; AAttr => dure}}; + + copula : Number => Str = + table {Sg => "is" ; Pl => "zijn"}; +} diff --git a/examples/gadt-transfer/FoodsEng.gf b/examples/gadt-transfer/FoodsEng.gf new file mode 100644 index 000000000..e7359a4ff --- /dev/null +++ b/examples/gadt-transfer/FoodsEng.gf @@ -0,0 +1,43 @@ +-- (c) 2009 Aarne Ranta under LGPL + +concrete FoodsEng of Foods = { + flags language = en_US; + lincat + Comment, Quality = {s : Str} ; + Kind = {s : Number => Str} ; + Item = {s : Str ; n : Number} ; + lin + Pred item quality = + {s = item.s ++ copula ! item.n ++ quality.s} ; + This = det Sg "this" ; + That = det Sg "that" ; + These = det Pl "these" ; + Those = det Pl "those" ; + Mod quality kind = + {s = \\n => quality.s ++ kind.s ! n} ; + Wine = regNoun "wine" ; + Cheese = regNoun "cheese" ; + Fish = noun "fish" "fish" ; + Pizza = regNoun "pizza" ; + Very a = {s = "very" ++ a.s} ; + Fresh = adj "fresh" ; + Warm = adj "warm" ; + Italian = adj "Italian" ; + Expensive = adj "expensive" ; + Delicious = adj "delicious" ; + Boring = adj "boring" ; + param + Number = Sg | Pl ; + oper + det : Number -> Str -> + {s : Number => Str} -> {s : Str ; n : Number} = + \n,det,noun -> {s = det ++ noun.s ! n ; n = n} ; + noun : Str -> Str -> {s : Number => Str} = + \man,men -> {s = table {Sg => man ; Pl => men}} ; + regNoun : Str -> {s : Number => Str} = + \car -> noun car (car + "s") ; + adj : Str -> {s : Str} = + \cold -> {s = cold} ; + copula : Number => Str = + table {Sg => "is" ; Pl => "are"} ; +} diff --git a/examples/gadt-transfer/Makefile b/examples/gadt-transfer/Makefile new file mode 100644 index 000000000..7399656f6 --- /dev/null +++ b/examples/gadt-transfer/Makefile @@ -0,0 +1,4 @@ +all: + gf -make -output-format=haskell --haskell=gadt FoodsEng.gf FoodsDut.gf + ghc --make VeryFoods.hs + diff --git a/examples/gadt-transfer/README b/examples/gadt-transfer/README new file mode 100644 index 000000000..10ff7543e --- /dev/null +++ b/examples/gadt-transfer/README @@ -0,0 +1,35 @@ +AR 5/3/2011 + +Example on using GADT and composOp in transfer. + +To compile: + + make + +To test: + + echo "this expensive boring wine is warm" | ./VeryFoods + this expensive very boring wine is warm + + echo "deze dure wijn is saai" | ./VeryFoods + deze dure wijn is erg saai + +Functionality: wraps every occurrence of "boring" with "very". + +This is implemented with a function that needs only two cases: one for "Boring" and another +for the rest of trees. On the method, see + + B. Bringert and A. Ranta. + A Pattern for Almost Compositional Functions. + Journal of Functional Programming, 18(5-6), pp. 567-598, 2008. + http://www.cse.chalmers.se/alumni/bringert/publ/composOp-jfp/composOp-jfp.pdf + +Source code: + + VeryFoods.hs -- main Haskell module, hand-written + Makefile + Foods.gf, FoodsEng.gf, FoodsDut.gf -- from GF/contrib/summerschool/foods/ + +Foods.hs and Foods.pgf are generated by 'make'. + + diff --git a/examples/gadt-transfer/VeryFoods.hs b/examples/gadt-transfer/VeryFoods.hs new file mode 100644 index 000000000..ad6b6dc7f --- /dev/null +++ b/examples/gadt-transfer/VeryFoods.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module Main where + +import PGF +import Foods + +-- example of using GADT: turn every occurrence of "boring" to "very boring" + +main = do + pgf <- readPGF "Foods.pgf" + interact (doVery pgf) + +doVery pgf s = case parseAllLang pgf (startCat pgf) s of + (l,t:_):_ -> unlines $ return $ linearize pgf l $ gf $ veryC $ fg t + +veryC :: GComment -> GComment +veryC = very + +very :: forall a. Foods.Tree a -> Foods.Tree a +very t = case t of + GBoring -> GVery GBoring + _ -> composOp very t + diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index 0546402ce..6c05db974 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -34,7 +34,7 @@ grammar2haskell :: Options -> PGF -> String grammar2haskell opts name gr = foldr (++++) [] $ - pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr'] + pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos where gr' = hSkeleton gr gadt = haskellOption opts HaskellGADT lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat @@ -44,11 +44,19 @@ grammar2haskell opts name gr = foldr (++++) [] $ | otherwise = [] types | gadt = datatypesGADT gId lexical gr' | otherwise = datatypes gId lexical gr' + compos | gadt = prCompos gId lexical gr' ++ composClass + | otherwise = [] -haskPreamble name = +haskPreamble gadt name = [ "module " ++ name ++ " where", - "", + "" + ] ++ + (if gadt then [ + "import Control.Monad.Identity", + "import Data.Monoid" + ] else []) ++ + [ "import PGF hiding (Tree)", "import qualified PGF", "----------------------------------------------------", @@ -134,6 +142,25 @@ hDatatypeGADT gId lexical (cat, rules) ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] where t = "Tree" +++ gId cat ++ "_" +prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String] +prCompos gId lexical (_,catrules) = + ["instance Compos Tree where", + " compos r a f t = case t of"] + ++ + [" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, (f,xs) <- rs, not (null xs)] + ++ + [" _ -> r t"] + where + prComposCons f xs = let vs = mkVars (length xs) in + f +++ unwords vs +++ "->" +++ rhs f (zip vs xs) + rhs f vcs = "r" +++ f +++ unwords (map prRec vcs) + prRec (v,c) + | isList c = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v + | otherwise = "`a`" +++ "f" +++ v + isList c = case lookup c catrules of + Just rs -> isListCat (c,rs) + _ -> False + gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs @@ -158,10 +185,10 @@ hInstance gId lexical m (cat,rules) 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]] mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" +mkVars n = ["x" ++ show i | i <- [1..n]] ----fInstance m ("Cn",_) = "" --- fInstance _ _ m (cat,[]) = "" @@ -228,3 +255,33 @@ isConsFun f = "Cons" `isPrefixOf` f baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int baseSize (_,rules) = length bs where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules + +composClass :: [String] +composClass = + [ + "", + "class Compos t where", + " compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)", + " -> (forall a. t a -> m (t a)) -> t c -> m (t c)", + "", + "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c", + "composOp f = runIdentity . composOpM (Identity . f)", + "", + "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)", + "composOpM = compos return ap", + "", + "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()", + "composOpM_ = composOpFold (return ()) (>>)", + "", + "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m", + "composOpMonoid = composOpFold mempty mappend", + "", + "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b", + "composOpMPlus = composOpFold mzero mplus", + "", + "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b", + "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)", + "", + "newtype C b a = C { unC :: b }" + ] +