Added Show isntance generation to haskell_gadt.

1 files changed, 22 insertions, 1 deletions

diff --git a/src/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs
index 1325ae52c..eae98d3f4 100644
--- a/src/GF/API/GrammarToHaskell.hs
+++ b/src/GF/API/GrammarToHaskell.hs
@@ -34,7 +34,8 @@ grammar2haskell gr = foldr (++++) [] $
 grammar2haskellGADT :: GFC.CanonGrammar -> String
 grammar2haskellGADT gr = foldr (++++) [] $  
   ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
-  haskPreamble ++ [datatypesGADT gr', composInstance gr', gfinstances gr', fginstances gr']
+  haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT gr', 
+                   gfinstances gr', fginstances gr']
     where gr' = hSkeleton gr
 
 -- | by this you can prefix all identifiers with stg; the default is 'G'
@@ -206,6 +207,26 @@ composInstance (_,skel) = unlines $
                    x:_ -> isListCat x
     builtin = ["GString", "GInt", "GFloat"]
 
+showInstanceGADT :: (String,HSkeleton) -> String
+showInstanceGADT (_,skel) = unlines $
+            ["instance Show (Tree c) where",
+	     "  showsPrec n t = case t of"]
+	     ++ map ("    "++) (concatMap prShowCat skel)
+	     ++ ["   where opar n = if n > 0 then showChar '(' else id",
+	         "         cpar n = if n > 0 then showChar ')' else id"]
+  where 
+  prShowCat c@(cat, fs)
+      | isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"]
+      | otherwise = map (prShowFun cat) fs
+  prShowFun :: OIdent -> (OIdent,[OIdent]) -> String
+  prShowFun cat (fun,args) 
+      | null vars = gId fun +++ "->" +++ "showString" +++ show fun
+      | otherwise = gId fun +++ unwords vars +++ "->" 
+			     +++ "opar n . showString" +++ show fun
+			     +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars]
+			     +++ ". cpar n"
+      where vars = ["x" ++ show n | n <- [1..length args]]
+
 hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
 hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
   collectR rr hh =