msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Merge pull request #120 from GrammaticalFramework/haskell-export

Browse Source 
Add --haskell=pgf2 flag
This commit is contained in:
John J. Camilleri
2021-07-02 09:00:45 +02:00
committed by GitHub
parent d5c6aec3ec b090e9b0ff
commit 3df04295d9
2 changed files with 120 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

120
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/06/17 12:39:07 $ -- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $ -- > CVS $Revision: 1.8 $
-- --
@@ -22,7 +22,7 @@ import PGF.Internal
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.Option import GF.Infra.Option
import Data.List --(isPrefixOf, find, intersperse) import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
import qualified Data.Map as Map import qualified Data.Map as Map
type Prefix = String -> String type Prefix = String -> String
@@ -34,11 +34,12 @@ grammar2haskell :: Options
-> PGF -> PGF
-> String -> String
grammar2haskell opts name gr = foldr (++++) [] $ grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name derivingClause extraImports ++ pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
[types, gfinstances gId lexical gr'] ++ compos [types, gfinstances gId lexical gr'] ++ compos
where gr' = hSkeleton gr where gr' = hSkeleton gr
gadt = haskellOption opts HaskellGADT gadt = haskellOption opts HaskellGADT
dataExt = haskellOption opts HaskellData dataExt = haskellOption opts HaskellData
pgf2 = haskellOption opts HaskellPGF2
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
| otherwise = ("G"++) . rmForbiddenChars | otherwise = ("G"++) . rmForbiddenChars
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
derivingClause derivingClause
| dataExt = "deriving (Show,Data)" | dataExt = "deriving (Show,Data)"
| otherwise = "deriving Show" | otherwise = "deriving Show"
extraImports | gadt = ["import Control.Monad.Identity", extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
"import Data.Monoid"]
| dataExt = ["import Data.Data"] | dataExt = ["import Data.Data"]
| otherwise = [] | otherwise = []
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
| otherwise = ["import PGF hiding (Tree)"]
types | gadt = datatypesGADT gId lexical gr' types | gadt = datatypesGADT gId lexical gr'
| otherwise = datatypes gId derivingClause lexical gr' | otherwise = datatypes gId derivingClause lexical gr'
compos | gadt = prCompos gId lexical gr' ++ composClass compos | gadt = prCompos gId lexical gr' ++ composClass
| otherwise = [] | otherwise = []
haskPreamble gadt name derivingClause extraImports = haskPreamble :: Bool -> String -> String -> [String] -> [String]
haskPreamble gadt name derivingClause imports =
[ [
"module " ++ name ++ " where", "module " ++ name ++ " where",
"" ""
] ++ extraImports ++ [ ] ++ imports ++ [
"import PGF hiding (Tree)", "",
"----------------------------------------------------", "----------------------------------------------------",
"-- automatic translation from GF to Haskell", "-- automatic translation from GF to Haskell",
"----------------------------------------------------", "----------------------------------------------------",
@@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports =
"" ""
] ]
predefInst :: Bool -> String -> String -> String -> String -> String -> String
predefInst gadt derivingClause gtyp typ destr consr = predefInst gadt derivingClause gtyp typ destr consr =
(if gadt (if gadt
then [] then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n") else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
) )
++ ++
"instance Gf" +++ gtyp +++ "where" ++++ "instance Gf" +++ gtyp +++ "where" ++++
@@ -103,10 +107,10 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
@@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
lexicalConstructor :: OIdent -> String lexicalConstructor :: OIdent -> String
lexicalConstructor cat = "Lex" ++ cat lexicalConstructor cat = "Lex" ++ cat
predefTypeSkel :: HSkeleton
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]] predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
-- GADT version of data types -- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypesGADT gId lexical (_,skel) = unlines $ datatypesGADT gId lexical (_,skel) = unlines $
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++ concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
[ [
"", "",
"data Tree :: * -> * where" "data Tree :: * -> * where"
] ++ ] ++
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++ concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
[ [
" GString :: String -> Tree GString_", " GString :: String -> Tree GString_",
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
"data"+++gId cat++"_"] "data"+++gId cat++"_"]
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hDatatypeGADT gId lexical (cat, rules) hDatatypeGADT gId lexical (cat, rules)
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise = | otherwise =
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
| (f,args) <- nonLexicalRules (lexical cat) rules ] | (f,args) <- nonLexicalRules (lexical cat) rules ]
++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
where t = "Tree" +++ gId cat ++ "_" where t = "Tree" +++ gId cat ++ "_"
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hEqGADT gId lexical (cat, rules) hEqGADT gId lexical (cat, rules)
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
| otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules] | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else [] ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
where where
patt s (f,xs) = unwords (gId f : mkSVars s (length xs)) patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
(x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"]) (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
listr c = (c,["foo"]) -- foo just for length = 1 listr c = (c,["foo"]) -- foo just for length = 1
listeqs = "and [x == y | (x,y) <- zip x1 y1]" listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
prCompos gId lexical (_,catrules) = prCompos gId lexical (_,catrules) =
["instance Compos Tree where", ["instance Compos Tree where",
" compos r a f t = case t of"] " compos r a f t = case t of"]
++ ++
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)), [" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
(f,xs) <- rs, not (null xs)] (f,xs) <- rs, not (null xs)]
++ ++
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)] [" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
++ ++
[" _ -> r t"] [" _ -> r t"]
where where
prComposCons f xs = let vs = mkVars (length xs) in prComposCons f xs = let vs = mkVars (length xs) in
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs) f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs) rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
prRec f (v,c) prRec f (v,c)
| isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v | isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
| otherwise = "`a`" +++ "f" +++ v | otherwise = "`a`" +++ "f" +++ v
isList f = (gId "List") `isPrefixOf` f isList f = gId "List" `isPrefixOf` f
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance gId _ m (cat,[]) = unlines [ hInstance gId _ m (cat,[]) = unlines [
"instance Show" +++ gId cat, "instance Show" +++ gId cat,
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
" gf _ = undefined", " gf _ = undefined",
" fg _ = undefined" " fg _ = undefined"
] ]
hInstance gId lexical m (cat,rules) hInstance gId lexical m (cat,rules)
| isListCat (cat,rules) = | isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++ "instance Gf" +++ gId cat +++ "where" ++++
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" " gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
" gf (" ++ gId cat +++ "(x:xs)) = " " gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
-- no show for GADTs -- no show for GADTs
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" -- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
| otherwise = | otherwise =
"instance Gf" +++ gId cat +++ "where\n" ++ "instance Gf" +++ gId cat +++ "where\n" ++
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
ec = elemCat cat ec = elemCat cat
baseVars = mkVars (baseSize (cat,rules)) baseVars = mkVars (baseSize (cat,rules))
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
"=" +++ mkRHS f xx' "=" +++ mkRHS f xx'
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
mkVars :: Int -> [String]
mkVars = mkSVars "x" mkVars = mkSVars "x"
mkSVars :: String -> Int -> [String]
mkSVars s n = [s ++ show i | i <- [1..n]] mkSVars s n = [s ++ show i | i <- [1..n]]
----fInstance m ("Cn",_) = "" --- ----fInstance m ("Cn",_) = "" ---
fInstance _ _ m (cat,[]) = "" fInstance _ _ m (cat,[]) = ""
fInstance gId lexical m (cat,rules) = fInstance gId lexical m (cat,rules) =
" fg t =" ++++ " fg t =" ++++
(if isList (if isList
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of" then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++ else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
" Just (i," ++ " Just (i," ++
"[" ++ prTList "," xx' ++ "])" +++ "[" ++ prTList "," xx' ++ "])" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] where
mkRHS f vars xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
| isList = mkRHS f vars
if "Base" `isPrefixOf` f | isList =
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" if "Base" `isPrefixOf` f
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1) then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
| otherwise = else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
gId f +++ | otherwise =
prTList " " [prParenth ("fg" +++ x) | x <- vars] gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton) hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr = hSkeleton gr =
(showCId (absname gr), (showCId (absname gr),
let fs = let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns] fs@((_, (_,c)):_) <- fns]
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)] in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
) )
where where
cts = Map.keys (cats (abstract gr)) cts = Map.keys (cats (abstract gr))
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
-} -}
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where c = elemCat cat where
fs = map fst rules c = elemCat cat
fs = map fst rules
-- | Gets the element category of a list category. -- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent elemCat :: OIdent -> OIdent
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
composClass :: [String] composClass :: [String]
composClass = composClass =
[ [
"", "",
"class Compos t where", "class Compos t where",
@@ -337,4 +348,3 @@ composClass =
"", "",
"newtype C b a = C { unC :: b }" "newtype C b a = C { unC :: b }"
] ]

104
src/compiler/GF/Infra/Option.hs
View File

@@ -2,13 +2,13 @@ module GF.Infra.Option
( (
-- ** Command line options -- ** Command line options
-- *** Option types -- *** Option types
Options, Options,
Flags(..), Flags(..),
Mode(..), Phase(..), Verbosity(..), Mode(..), Phase(..), Verbosity(..),
OutputFormat(..), OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Pass(..), Recomp(..), Dump(..), Pass(..), Recomp(..),
outputFormatsExpl, outputFormatsExpl,
-- *** Option parsing -- *** Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths, parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- *** Option pretty-printing -- *** Option pretty-printing
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Fail as Fail
usageHeader :: String usageHeader :: String
usageHeader = unlines usageHeader = unlines
["Usage: gf [OPTIONS] [FILE [...]]", ["Usage: gf [OPTIONS] [FILE [...]]",
"", "",
"How each FILE is handled depends on the file name suffix:", "How each FILE is handled depends on the file name suffix:",
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
data OutputFormat = FmtPGFPretty data OutputFormat = FmtPGFPretty
| FmtCanonicalGF | FmtCanonicalGF
| FmtCanonicalJson | FmtCanonicalJson
| FmtJavaScript | FmtJavaScript
| FmtJSON | FmtJSON
| FmtPython | FmtPython
| FmtHaskell | FmtHaskell
| FmtJava | FmtJava
| FmtProlog | FmtProlog
| FmtBNF | FmtBNF
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
| FmtNoLR | FmtNoLR
| FmtSRGS_XML | FmtSRGS_XML
| FmtSRGS_XML_NonRec | FmtSRGS_XML_NonRec
| FmtSRGS_ABNF | FmtSRGS_ABNF
| FmtSRGS_ABNF_NonRec | FmtSRGS_ABNF_NonRec
| FmtJSGF | FmtJSGF
| FmtGSL | FmtGSL
| FmtVoiceXML | FmtVoiceXML
| FmtSLF | FmtSLF
| FmtRegExp | FmtRegExp
| FmtFA | FmtFA
deriving (Eq,Ord) deriving (Eq,Ord)
data SISRFormat = data SISRFormat =
-- | SISR Working draft 1 April 2003 -- | SISR Working draft 1 April 2003
-- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/> -- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
SISR_WD20030401 SISR_WD20030401
| SISR_1_0 | SISR_1_0
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR data CFGTransform = CFGNoLR
| CFGRegular | CFGRegular
| CFGTopDownFilter | CFGTopDownFilter
| CFGBottomUpFilter | CFGBottomUpFilter
| CFGStartCatOnly | CFGStartCatOnly
| CFGMergeIdentical | CFGMergeIdentical
| CFGRemoveCycles | CFGRemoveCycles
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical data HaskellOption = HaskellNoPrefix
| HaskellConcrete | HaskellVariants | HaskellData | HaskellGADT
| HaskellLexical
| HaskellConcrete
| HaskellVariants
| HaskellData
| HaskellPGF2
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat data Warning = WarnMissingLincat
@@ -196,7 +201,7 @@ instance Show Options where
parseOptions :: ErrorMonad err => parseOptions :: ErrorMonad err =>
[String] -- ^ list of string arguments [String] -- ^ list of string arguments
-> err (Options, [FilePath]) -> err (Options, [FilePath])
parseOptions args parseOptions args
| not (null errs) = errors errs | not (null errs) = errors errs
| otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss) | otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss)
return (opts, files) return (opts, files)
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
-> err Options -> err Options
parseModuleOptions args = do parseModuleOptions args = do
(opts,nonopts) <- parseOptions args (opts,nonopts) <- parseOptions args
if null nonopts if null nonopts
then return opts then return opts
else errors $ map ("Non-option among module options: " ++) nonopts else errors $ map ("Non-option among module options: " ++) nonopts
@@ -281,7 +286,7 @@ defaultFlags = Flags {
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optOptimizePGF = False, optOptimizePGF = False,
optSplitPGF = False, optSplitPGF = False,
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical], CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [], optLibraryPath = [],
optStartCat = Nothing, optStartCat = Nothing,
@@ -301,7 +306,7 @@ defaultFlags = Flags {
-- | Option descriptions -- | Option descriptions
{-# NOINLINE optDescr #-} {-# NOINLINE optDescr #-}
optDescr :: [OptDescr (Err Options)] optDescr :: [OptDescr (Err Options)]
optDescr = optDescr =
[ [
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -327,44 +332,44 @@ optDescr =
-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations", -- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
-- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations", -- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT") Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:", (unlines ["Output format. FMT can be one of:",
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
"Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar, "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
"Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf, "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
"Abstract only: haskell, ..."]), -- prolog_abs, "Abstract only: haskell, ..."]), -- prolog_abs,
Option [] ["sisr"] (ReqArg sisrFmt "FMT") Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.", (unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]), "FMT can be one of: old, 1.0"]),
Option [] ["haskell"] (ReqArg hsOption "OPTION") Option [] ["haskell"] (ReqArg hsOption "OPTION")
("Turn on an optional feature when generating Haskell data types. OPTION = " ("Turn on an optional feature when generating Haskell data types. OPTION = "
++ concat (intersperse " | " (map fst haskellOptionNames))), ++ concat (intersperse " | " (map fst haskellOptionNames))),
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.", "Treat CAT as a lexical category.",
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
"Treat CAT as a literal category.", "Treat CAT as a literal category.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR") Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
"Save output files (other than .gfo files) in DIR.", "Save output files (other than .gfo files) in DIR.",
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
"Overrides the value of GF_LIB_PATH.", "Overrides the value of GF_LIB_PATH.",
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
"Always recompile from source.", "Always recompile from source.",
Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer)) Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
"(default) Recompile from source if the source is newer than the .gfo file.", "(default) Recompile from source if the source is newer than the .gfo file.",
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
"Never recompile from source, if there is already .gfo file.", "Never recompile from source, if there is already .gfo file.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.", Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
Option ['n'] ["name"] (ReqArg name "NAME") Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ", (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
"with suffixes depending on the formats, and, when relevant, ", "with suffixes depending on the formats, and, when relevant, ",
"internally in the output."]), "internally in the output."]),
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
Option [] ["preproc"] (ReqArg preproc "CMD") Option [] ["preproc"] (ReqArg preproc "CMD")
(unlines ["Use CMD to preprocess input files.", (unlines ["Use CMD to preprocess input files.",
"Multiple preprocessors can be used by giving this option multiple times."]), "Multiple preprocessors can be used by giving this option multiple times."]),
Option [] ["coding"] (ReqArg coding "ENCODING") Option [] ["coding"] (ReqArg coding "ENCODING")
("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."), ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -372,7 +377,7 @@ optDescr =
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).", Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).", Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
Option [] ["optimize"] (ReqArg optimize "OPT") Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none", "Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True)) Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file", "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
@@ -447,7 +452,7 @@ optDescr =
optimize x = case lookup x optimizationPackages of optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p } Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x Nothing -> fail $ "Unknown optimization package: " ++ x
optimize_pgf x = set $ \o -> o { optOptimizePGF = x } optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
splitPGF x = set $ \o -> o { optSplitPGF = x } splitPGF x = set $ \o -> o { optSplitPGF = x }
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
outputFormats = map fst outputFormatsExpl outputFormats = map fst outputFormatsExpl
outputFormatsExpl :: [((String,OutputFormat),String)] outputFormatsExpl :: [((String,OutputFormat),String)]
outputFormatsExpl = outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"), [(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"), (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
@@ -504,11 +509,11 @@ instance Read OutputFormat where
readsPrec = lookupReadsPrec outputFormats readsPrec = lookupReadsPrec outputFormats
optimizationPackages :: [(String, Set Optimization)] optimizationPackages :: [(String, Set Optimization)]
optimizationPackages = optimizationPackages =
[("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("values", Set.fromList [OptStem,OptCSE,OptExpand]), ("values", Set.fromList [OptStem,OptCSE,OptExpand]),
("noexpand", Set.fromList [OptStem,OptCSE]), ("noexpand", Set.fromList [OptStem,OptCSE]),
-- deprecated -- deprecated
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -516,7 +521,7 @@ optimizationPackages =
] ]
cfgTransformNames :: [(String, CFGTransform)] cfgTransformNames :: [(String, CFGTransform)]
cfgTransformNames = cfgTransformNames =
[("nolr", CFGNoLR), [("nolr", CFGNoLR),
("regular", CFGRegular), ("regular", CFGRegular),
("topdown", CFGTopDownFilter), ("topdown", CFGTopDownFilter),
@@ -532,7 +537,8 @@ haskellOptionNames =
("lexical", HaskellLexical), ("lexical", HaskellLexical),
("concrete", HaskellConcrete), ("concrete", HaskellConcrete),
("variants", HaskellVariants), ("variants", HaskellVariants),
("data", HaskellData)] ("data", HaskellData),
("pgf2", HaskellPGF2)]
-- | This is for bacward compatibility. Since GHC 6.12 we -- | This is for bacward compatibility. Since GHC 6.12 we
-- started using the native Unicode support in GHC but it -- started using the native Unicode support in GHC but it
@@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]"
_ -> fail $ "Expected [on,off], got: " ++ show x _ -> fail $ "Expected [on,off], got: " ++ show x
readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
readOutputFormat s = readOutputFormat s =
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
-- FIXME: this is a copy of the function in GF.Devel.UseIO. -- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
isPathSep :: Char -> Bool isPathSep :: Char -> Bool
isPathSep c = c == ':' || c == ';' isPathSep c = c == ':' || c == ';'
-- --
-- * Convenience functions for checking options -- * Convenience functions for checking options
-- --
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
isLexicalCat :: Options -> String -> Bool isLexicalCat :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts) isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
-- --
-- * Convenience functions for setting options -- * Convenience functions for setting options
-- --
@@ -623,8 +629,8 @@ readMaybe s = case reads s of
toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
toEnumBounded i = let mi = minBound toEnumBounded i = let mi = minBound
ma = maxBound `asTypeOf` mi ma = maxBound `asTypeOf` mi
in if i >= fromEnum mi && i <= fromEnum ma in if i >= fromEnum mi && i <= fromEnum ma
then Just (toEnum i `asTypeOf` mi) then Just (toEnum i `asTypeOf` mi)
else Nothing else Nothing