Added Compos instance generation to the haskell_gadt printer. Added GF.Data.Compos module which is imported by the code generated by haskell_gadt.

src/GF/API/GrammarToHaskell.hs

@@ -23,6 +23,7 @@ import GF.Infra.Modules
 import GF.Data.Operations
 
 import Data.List (isPrefixOf, find, intersperse)
+import Data.Maybe (fromMaybe)
 
 -- | the main function
 grammar2haskell :: GFC.CanonGrammar -> String
@@ -33,7 +34,7 @@ grammar2haskell gr = foldr (++++) [] $
 grammar2haskellGADT :: GFC.CanonGrammar -> String
 grammar2haskellGADT gr = foldr (++++) [] $  
   ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
-  haskPreamble ++ [datatypesGADT gr', gfinstances gr', fginstances gr']
+  haskPreamble ++ [datatypesGADT gr', composInstance gr', gfinstances gr', fginstances gr']
     where gr' = hSkeleton gr
 
 -- | by this you can prefix all identifiers with stg; the default is 'G'
@@ -48,7 +49,11 @@ haskPreamble =
   "import GF.Grammar.Grammar",
   "import GF.Grammar.PrGrammar",
   "import GF.Grammar.Macros",
+  "import GF.Data.Compos",
   "import GF.Data.Operations",
+  "",
+  "import Control.Applicative (pure,(<*>))",
+  "import Data.Traversable (traverse)",
   "----------------------------------------------------",
   "-- automatic translation from GF to Haskell",
   "----------------------------------------------------",
@@ -174,6 +179,32 @@ fInstance m (cat,rules) =
 		     gId f +++  
 		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
 
+composInstance :: (String,HSkeleton) -> String
+composInstance (_,skel) = unlines $
+    ["instance Compos Tree where",
+     "  compos f t = case t of"]
+    ++ map ("      "++) (concatMap prComposCat skel
+                         ++ if not allRecursive then ["_ -> pure t"] else [])
+    where
+    prComposCat c@(cat, fs) 
+        | isListCat c = [gId cat +++ "xs" +++ "->" 
+                         +++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"]
+        | otherwise = concatMap (prComposFun cat) fs
+    prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String]
+    prComposFun cat c@(fun,args) 
+	| any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs]
+        | otherwise = []
+      where vars = ["x" ++ show n | n <- [1..length args]]
+            rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args)
+	        where prRec var typ
+                          | not (isTreeType typ) = "<*>" +++ "pure" +++ var
+			  | otherwise = "<*>" +++ "f" +++ var
+    allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs] 
+    isTreeType cat = cat `elem` (map fst skel ++ builtin)
+    isList cat = case filter ((==cat) . fst) skel of
+                   [] -> error $ "Unknown cat " ++ show cat
+                   x:_ -> isListCat x
+    builtin = ["GString", "GInt", "GFloat"]
 
 hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
 hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where

src/GF/Data/Compos.hs

@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module GF.Data.Compos (Compos(..),composOp,composM,composM_,composFold) where
+
+import Control.Applicative (Applicative(..), Const(..), WrappedMonad(..))
+import Data.Monoid (Monoid(..))
+
+class Compos t where
+  compos :: Applicative f => (forall a. t a -> f (t a)) -> t c -> f (t c)
+
+composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
+composOp f = runIdentity . compos (Identity . f)
+
+composFold :: (Monoid o, Compos t) => (forall a. t a -> o) -> t c -> o
+composFold f = getConst . compos (Const . f)
+
+composM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
+composM f = unwrapMonad . compos (WrapMonad . f)
+
+composM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
+composM_ f = unwrapMonad_ . composFold (WrapMonad_ . f)
+
+
+newtype Identity a = Identity { runIdentity :: a }
+
+instance Functor Identity where
+  fmap f (Identity x) = Identity (f x)
+
+instance Applicative Identity where
+  pure                       = Identity
+  Identity f <*> Identity x  = Identity (f x)
+
+
+newtype WrappedMonad_ m = WrapMonad_ { unwrapMonad_ :: m () }
+
+instance Monad m => Monoid (WrappedMonad_ m) where
+  mempty  = WrapMonad_ (return ())
+  WrapMonad_ x `mappend` WrapMonad_ y = WrapMonad_  (x >> y)