forked from GitHub/gf-core
Added option to treat some categories as lexical when generating Haskell data types.
This commit is contained in:
bjorn
@@ -14,13 +14,14 @@
|
||||
-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where
|
||||
module GF.Compile.GFCCtoHaskell (grammar2haskell) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
import PGF.Macros
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.Option
|
||||
import GF.Text.UTF8
|
||||
|
||||
import Data.List --(isPrefixOf, find, intersperse)
|
||||
@@ -29,24 +30,21 @@ import qualified Data.Map as Map
|
||||
type Prefix = String -> String
|
||||
|
||||
-- | the main function
|
||||
grammar2haskell :: String -- ^ Constructor prefix
|
||||
grammar2haskell :: Options
|
||||
-> String -- ^ Module name.
|
||||
-> PGF
|
||||
-> String
|
||||
grammar2haskell prefix name gr = encodeUTF8 $ foldr (++++) [] $
|
||||
haskPreamble name ++ [datatypes gId gr', gfinstances gId gr']
|
||||
grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $
|
||||
pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr']
|
||||
where gr' = hSkeleton gr
|
||||
gId = (prefix++)
|
||||
|
||||
grammar2haskellGADT :: String -- ^ Constructor prefix
|
||||
-> String -- ^ Module name.
|
||||
-> PGF
|
||||
-> String
|
||||
grammar2haskellGADT prefix name gr = encodeUTF8 $ foldr (++++) [] $
|
||||
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
|
||||
haskPreamble name ++ [datatypesGADT gId gr', gfinstances gId gr']
|
||||
where gr' = hSkeleton gr
|
||||
gId = (prefix++)
|
||||
gadt = haskellOption opts HaskellGADT
|
||||
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
|
||||
gId | haskellOption opts HaskellNoPrefix = id
|
||||
| otherwise = ("G"++)
|
||||
pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"]
|
||||
| otherwise = []
|
||||
types | gadt = datatypesGADT gId lexical gr'
|
||||
| otherwise = datatypes gId lexical gr'
|
||||
|
||||
haskPreamble name =
|
||||
[
|
||||
@@ -86,49 +84,62 @@ type OIdent = String
|
||||
|
||||
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
|
||||
datatypes, gfinstances :: Prefix -> (String,HSkeleton) -> String
|
||||
datatypes gId = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId)) . snd
|
||||
gfinstances gId (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId m)) g
|
||||
datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
|
||||
|
||||
hDatatype :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
gfInstance :: Prefix -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
|
||||
|
||||
hDatatype _ ("Cn",_) = "" ---
|
||||
hDatatype _ (cat,[]) = ""
|
||||
hDatatype gId (cat,rules) | isListCat (cat,rules) =
|
||||
|
||||
hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
hDatatype _ _ ("Cn",_) = "" ---
|
||||
hDatatype _ _ (cat,[]) = ""
|
||||
hDatatype gId _ (cat,rules) | isListCat (cat,rules) =
|
||||
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
|
||||
+++ "deriving Show"
|
||||
hDatatype gId (cat,rules) =
|
||||
hDatatype gId lexical (cat,rules) =
|
||||
"data" +++ gId cat +++ "=" ++
|
||||
(if length rules == 1 then "" else "\n ") +++
|
||||
foldr1 (\x y -> x ++ "\n |" +++ y)
|
||||
[gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- rules] ++++
|
||||
foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
|
||||
" deriving Show"
|
||||
where
|
||||
constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
|
||||
|
||||
nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])]
|
||||
nonLexicalRules False rules = rules
|
||||
nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
|
||||
|
||||
lexicalConstructor :: OIdent -> String
|
||||
lexicalConstructor cat = "Lex" ++ cat
|
||||
|
||||
-- GADT version of data types
|
||||
datatypesGADT :: Prefix -> (String,HSkeleton) -> String
|
||||
datatypesGADT gId (_,skel) =
|
||||
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
|
||||
datatypesGADT gId lexical (_,skel) =
|
||||
unlines (concatMap (hCatTypeGADT gId) skel)
|
||||
+++++
|
||||
"data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId) skel)
|
||||
"data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel)
|
||||
|
||||
hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hCatTypeGADT gId (cat,rules)
|
||||
= ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
|
||||
"data"+++gId cat++"_"]
|
||||
|
||||
hDatatypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hDatatypeGADT gId (cat, rules)
|
||||
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
|
||||
hDatatypeGADT gId lexical (cat, rules)
|
||||
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
|
||||
| otherwise =
|
||||
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
|
||||
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
|
||||
| (f,args) <- nonLexicalRules (lexical cat) rules ]
|
||||
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
|
||||
where t = "Tree" +++ gId cat ++ "_"
|
||||
|
||||
gfInstance gId m crs = hInstance gId m crs ++++ fInstance gId m crs
|
||||
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
|
||||
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
|
||||
|
||||
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
|
||||
hInstance _ m (cat,[]) = ""
|
||||
hInstance gId m (cat,rules)
|
||||
hInstance _ _ m (cat,[]) = ""
|
||||
hInstance gId lexical m (cat,rules)
|
||||
| isListCat (cat,rules) =
|
||||
"instance Gf" +++ gId cat +++ "where" ++++
|
||||
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
|
||||
@@ -139,7 +150,8 @@ hInstance gId m (cat,rules)
|
||||
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
|
||||
| otherwise =
|
||||
"instance Gf" +++ gId cat +++ "where\n" ++
|
||||
unlines [mkInst f xx | (f,xx) <- rules]
|
||||
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = Fun (mkCId x) []"] else [])
|
||||
where
|
||||
ec = elemCat cat
|
||||
baseVars = mkVars (baseSize (cat,rules))
|
||||
@@ -152,11 +164,12 @@ hInstance gId m (cat,rules)
|
||||
|
||||
|
||||
----fInstance m ("Cn",_) = "" ---
|
||||
fInstance _ m (cat,[]) = ""
|
||||
fInstance gId m (cat,rules) =
|
||||
fInstance _ _ m (cat,[]) = ""
|
||||
fInstance gId lexical m (cat,rules) =
|
||||
" fg t =" ++++
|
||||
" case t of" ++++
|
||||
unlines [mkInst f xx | (f,xx) <- rules] ++++
|
||||
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
|
||||
(if lexical cat then " Fun i [] -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++
|
||||
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
|
||||
where
|
||||
mkInst f xx =
|
||||
|
||||
Reference in New Issue
Block a user