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

6 files changed, 178 insertions, 0 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
+