GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 09:32:53 -06:00
Code Issues Packages Projects Releases Wiki Activity

Added Show isntance generation to haskell_gadt.

Browse Source
This commit is contained in:
bringert
2007-10-20 18:57:38 +00:00
parent 173d0ae876
commit bc2cac719b
1 changed files with 22 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
src/GF/API/GrammarToHaskell.hs
View File

@@ -34,7 +34,8 @@ grammar2haskell gr = foldr (++++) [] $
grammar2haskellGADT :: GFC.CanonGrammar -> String grammar2haskellGADT :: GFC.CanonGrammar -> String
grammar2haskellGADT gr = foldr (++++) [] $ grammar2haskellGADT gr = foldr (++++) [] $
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ ["{-# 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 where gr' = hSkeleton gr
-- | by this you can prefix all identifiers with stg; the default is 'G' -- | by this you can prefix all identifiers with stg; the default is 'G'
@@ -206,6 +207,26 @@ composInstance (_,skel) = unlines $
x:_ -> isListCat x x:_ -> isListCat x
builtin = ["GString", "GInt", "GFloat"] 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 :: GFC.CanonGrammar -> (String,HSkeleton)
hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
collectR rr hh = collectR rr hh =