added composOp generation to haskell-gadt, and an example in examples/gadt-transfer

7 files changed, 239 insertions, 4 deletions

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 }"
+    ]
+