GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

replace GFCC with PGF in (almost) all places

Browse Source
This commit is contained in:
krasimir
2008-05-30 11:15:33 +00:00
parent 1172539a95
commit 8bb0c32a9c
20 changed files with 246 additions and 267 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
src-3.0/GF/Command/Commands.hs
View File

@@ -47,10 +47,10 @@ emptyCommandInfo = CommandInfo {
lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
lookCommand = Map.lookup lookCommand = Map.lookup
commandHelpAll :: MultiGrammar -> [Option] -> String commandHelpAll :: PGF -> [Option] -> String
commandHelpAll mgr opts = unlines commandHelpAll pgf opts = unlines
[commandHelp (isOpt "full" opts) (co,info) [commandHelp (isOpt "full" opts) (co,info)
| (co,info) <- Map.assocs (allCommands mgr)] | (co,info) <- Map.assocs (allCommands pgf)]
commandHelp :: Bool -> (String,CommandInfo) -> String commandHelp :: Bool -> (String,CommandInfo) -> String
commandHelp full (co,info) = unlines $ [ commandHelp full (co,info) = unlines $ [
@@ -82,14 +82,14 @@ isOpt :: String -> [Option] -> Bool
isOpt o opts = elem o [x | OOpt (Ident x) <- opts] isOpt o opts = elem o [x | OOpt (Ident x) <- opts]
-- this list must be kept sorted by the command name! -- this list must be kept sorted by the command name!
allCommands :: MultiGrammar -> Map.Map String CommandInfo allCommands :: PGF -> Map.Map String CommandInfo
allCommands mgr = Map.fromAscList [ allCommands pgf = Map.fromAscList [
("gr", emptyCommandInfo { ("gr", emptyCommandInfo {
longname = "generate_random", longname = "generate_random",
synopsis = "generates a list of random trees, by default one tree", synopsis = "generates a list of random trees, by default one tree",
flags = ["cat","number"], flags = ["cat","number"],
exec = \opts _ -> do exec = \opts _ -> do
ts <- generateRandom mgr (optCat opts) ts <- generateRandom pgf (optCat opts)
return $ fromTrees $ take (optNum opts) ts return $ fromTrees $ take (optNum opts) ts
}), }),
("gt", emptyCommandInfo { ("gt", emptyCommandInfo {
@@ -98,7 +98,7 @@ allCommands mgr = Map.fromAscList [
flags = ["cat","depth","number"], flags = ["cat","depth","number"],
exec = \opts _ -> do exec = \opts _ -> do
let dp = return $ valIntOpts "depth" 4 opts let dp = return $ valIntOpts "depth" 4 opts
let ts = generateAllDepth mgr (optCat opts) dp let ts = generateAllDepth pgf (optCat opts) dp
return $ fromTrees $ take (optNumInf opts) ts return $ fromTrees $ take (optNumInf opts) ts
}), }),
("h", emptyCommandInfo { ("h", emptyCommandInfo {
@@ -107,10 +107,10 @@ allCommands mgr = Map.fromAscList [
options = ["full"], options = ["full"],
exec = \opts ts -> return ([], case ts of exec = \opts ts -> return ([], case ts of
[t] -> let co = (showTree t) in [t] -> let co = (showTree t) in
case lookCommand co (allCommands mgr) of ---- new map ??!! case lookCommand co (allCommands pgf) of ---- new map ??!!
Just info -> commandHelp True (co,info) Just info -> commandHelp True (co,info)
_ -> "command not found" _ -> "command not found"
_ -> commandHelpAll mgr opts) _ -> commandHelpAll pgf opts)
}), }),
("l", emptyCommandInfo { ("l", emptyCommandInfo {
exec = \opts -> return . fromStrings . map (optLin opts), exec = \opts -> return . fromStrings . map (optLin opts),
@@ -127,33 +127,31 @@ allCommands mgr = Map.fromAscList [
}) })
] ]
where where
lin opts t = unlines [linearize mgr lang t | lang <- optLangs opts] lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts]
par opts s = concat [parse mgr lang (optCat opts) s | lang <- optLangs opts] par opts s = concat [parse pgf lang (optCat opts) s | lang <- optLangs opts]
optLin opts t = unlines [linea lang t | lang <- optLangs opts] where optLin opts t = unlines [linea lang t | lang <- optLangs opts] where
linea lang = case opts of linea lang = case opts of
_ | isOpt "all" opts -> allLinearize gr (mkCId lang) _ | isOpt "all" opts -> allLinearize pgf (mkCId lang)
_ | isOpt "table" opts -> tableLinearize gr (mkCId lang) _ | isOpt "table" opts -> tableLinearize pgf (mkCId lang)
_ | isOpt "term" opts -> termLinearize gr (mkCId lang) _ | isOpt "term" opts -> termLinearize pgf (mkCId lang)
_ | isOpt "record" opts -> recordLinearize gr (mkCId lang) _ | isOpt "record" opts -> recordLinearize pgf (mkCId lang)
_ -> linearize mgr lang _ -> linearize pgf lang
optLangs opts = case valIdOpts "lang" "" opts of optLangs opts = case valIdOpts "lang" "" opts of
"" -> languages mgr "" -> languages pgf
lang -> [lang] lang -> [lang]
optCat opts = valIdOpts "cat" (lookStartCat gr) opts optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
optNum opts = valIntOpts "number" 1 opts optNum opts = valIntOpts "number" 1 opts
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
gr = gfcc mgr
fromTrees ts = (ts,unlines (map showTree ts)) fromTrees ts = (ts,unlines (map showTree ts))
fromStrings ss = (map EStr ss, unlines ss) fromStrings ss = (map EStr ss, unlines ss)
fromString s = ([EStr s], s) fromString s = ([EStr s], s)
toStrings ts = [s | EStr s <- ts] toStrings ts = [s | EStr s <- ts]
prGrammar opts = case valIdOpts "printer" "" opts of prGrammar opts = case valIdOpts "printer" "" opts of
"cats" -> unwords $ categories mgr "cats" -> unwords $ categories pgf
v -> prGFCC (read v) gr v -> prPGF (read v) pgf

20
src-3.0/GF/Command/Importing.hs
View File

@@ -13,20 +13,18 @@ import Data.List (nubBy)
import System.FilePath import System.FilePath
-- import a grammar in an environment where it extends an existing grammar -- import a grammar in an environment where it extends an existing grammar
importGrammar :: MultiGrammar -> Options -> [FilePath] -> IO MultiGrammar importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
importGrammar mgr0 opts files = importGrammar pgf0 opts files =
case takeExtensions (last files) of case takeExtensions (last files) of
s | elem s [".gf",".gfo"] -> do s | elem s [".gf",".gfo"] -> do
res <- appIOE $ compileToGFCC opts files res <- appIOE $ compileToPGF opts files
case res of case res of
Ok gfcc2 -> do let gfcc3 = unionGFCC (gfcc mgr0) gfcc2 Ok pgf2 -> do return $ unionPGF pgf0 pgf2
return $ MultiGrammar gfcc3 Bad msg -> do putStrLn msg
Bad msg -> do putStrLn msg return pgf0
return mgr0 ".pgf" -> do
".gfcc" -> do pgf2 <- mapM file2pgf files >>= return . foldl1 unionPGF
gfcc2 <- mapM file2gfcc files >>= return . foldl1 unionGFCC return $ unionPGF pgf0 pgf2
let gfcc3 = unionGFCC (gfcc mgr0) gfcc2
return $ MultiGrammar gfcc3
importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar
importSource src0 opts files = do importSource src0 opts files = do

2
src-3.0/GF/Command/Interpreter.hs
View File

@@ -17,7 +17,7 @@ import GF.Data.ErrM ----
import qualified Data.Map as Map import qualified Data.Map as Map
data CommandEnv = CommandEnv { data CommandEnv = CommandEnv {
multigrammar :: MultiGrammar, multigrammar :: PGF,
commands :: Map.Map String CommandInfo commands :: Map.Map String CommandInfo
} }

20
src-3.0/GF/Compile.hs
View File

@@ -1,4 +1,4 @@
module GF.Compile (batchCompile, link, compileToGFCC) where module GF.Compile (batchCompile, link, compileToPGF) where
-- the main compiler passes -- the main compiler passes
import GF.Compile.GetGrammar import GF.Compile.GetGrammar
@@ -39,27 +39,31 @@ import PGF.Check
import PGF.Data import PGF.Data
-- | Compiles a number of source files and builds a 'GFCC' structure for them. -- | Compiles a number of source files and builds a 'PGF' structure for them.
compileToGFCC :: Options -> [FilePath] -> IOE GFCC compileToPGF :: Options -> [FilePath] -> IOE PGF
compileToGFCC opts fs = compileToPGF opts fs =
do gr <- batchCompile opts fs do gr <- batchCompile opts fs
let name = justModuleName (last fs) let name = justModuleName (last fs)
link opts name gr link opts name gr
link :: Options -> String -> SourceGrammar -> IOE GFCC link :: Options -> String -> SourceGrammar -> IOE PGF
link opts cnc gr = link opts cnc gr =
do gc1 <- putPointE Normal opts "linking ... " $ do gc1 <- putPointE Normal opts "linking ... " $
let (abs,gc0) = mkCanon2gfcc opts cnc gr let (abs,gc0) = mkCanon2gfcc opts cnc gr
in ioeIO $ checkGFCCio gc0 in case checkPGF gc0 of
Ok (gc,b) -> do
ioeIO $ putStrLn $ if b then "OK" else "Corrupted PGF"
return gc
Bad s -> fail s
return $ buildParser opts $ optimize opts gc1 return $ buildParser opts $ optimize opts gc1
optimize :: Options -> GFCC -> GFCC optimize :: Options -> PGF -> PGF
optimize opts = cse . suf optimize opts = cse . suf
where os = moduleFlag optOptimizations opts where os = moduleFlag optOptimizations opts
cse = if OptCSE `elem` os then cseOptimize else id cse = if OptCSE `elem` os then cseOptimize else id
suf = if OptStem `elem` os then suffixOptimize else id suf = if OptStem `elem` os then suffixOptimize else id
buildParser :: Options -> GFCC -> GFCC buildParser :: Options -> PGF -> PGF
buildParser opts = buildParser opts =
if moduleFlag optBuildParser opts then addParsers else id if moduleFlag optBuildParser opts then addParsers else id

16
src-3.0/GF/Compile/Export.hs
View File

@@ -1,8 +1,8 @@
module GF.Compile.Export where module GF.Compile.Export where
import PGF.Data (GFCC) import PGF.Data (PGF)
import PGF.Raw.Print (printTree) import PGF.Raw.Print (printTree)
import PGF.Raw.Convert (fromGFCC) import PGF.Raw.Convert (fromPGF)
import GF.Compile.GFCCtoHaskell import GF.Compile.GFCCtoHaskell
import GF.Compile.GFCCtoJS import GF.Compile.GFCCtoJS
import GF.Infra.Option import GF.Infra.Option
@@ -10,13 +10,13 @@ import GF.Text.UTF8
-- top-level access to code generation -- top-level access to code generation
prGFCC :: OutputFormat -> GFCC -> String prPGF :: OutputFormat -> PGF -> String
prGFCC fmt gr = case fmt of prPGF fmt gr = case fmt of
FmtGFCC -> printGFCC gr FmtPGF -> printPGF gr
FmtJavaScript -> gfcc2js gr FmtJavaScript -> pgf2js gr
FmtHaskell -> grammar2haskell gr FmtHaskell -> grammar2haskell gr
FmtHaskellGADT -> grammar2haskellGADT gr FmtHaskellGADT -> grammar2haskellGADT gr
printGFCC :: GFCC -> String printPGF :: PGF -> String
printGFCC = encodeUTF8 . printTree . fromGFCC printPGF = encodeUTF8 . printTree . fromPGF

6
src-3.0/GF/Compile/GFCCtoHaskell.hs
View File

@@ -27,12 +27,12 @@ import Data.List --(isPrefixOf, find, intersperse)
import qualified Data.Map as Map import qualified Data.Map as Map
-- | the main function -- | the main function
grammar2haskell :: GFCC -> String grammar2haskell :: PGF -> String
grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $ grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $
haskPreamble ++ [datatypes gr', gfinstances gr'] haskPreamble ++ [datatypes gr', gfinstances gr']
where gr' = hSkeleton gr where gr' = hSkeleton gr
grammar2haskellGADT :: GFCC -> String grammar2haskellGADT :: PGF -> String
grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $ grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
haskPreamble ++ [datatypesGADT gr', gfinstances gr'] haskPreamble ++ [datatypesGADT gr', gfinstances gr']
@@ -173,7 +173,7 @@ fInstance m (cat,rules) =
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: GFCC -> (String,HSkeleton) hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr = hSkeleton gr =
(prCId (absname gr), (prCId (absname gr),
[(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) | [(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) |

14
src-3.0/GF/Compile/GFCCtoJS.hs
View File

@@ -1,4 +1,4 @@
module GF.Compile.GFCCtoJS (gfcc2js) where module GF.Compile.GFCCtoJS (pgf2js) where
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
@@ -16,14 +16,14 @@ import qualified Data.Array as Array
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Map as Map import qualified Data.Map as Map
gfcc2js :: GFCC -> String pgf2js :: PGF -> String
gfcc2js gfcc = pgf2js pgf =
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where where
n = prCId $ absname gfcc n = prCId $ absname pgf
as = abstract gfcc as = abstract pgf
cs = Map.assocs (concretes gfcc) cs = Map.assocs (concretes pgf)
start = M.lookStartCat gfcc start = M.lookStartCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete] grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start as js_abstract = abstract2js start as
js_concrete = JS.EObj $ map (concrete2js start n) cs js_concrete = JS.EObj $ map (concrete2js start n) cs

20
src-3.0/GF/Compile/GrammarToGFCC.hs
View File

@@ -37,13 +37,13 @@ import Debug.Trace ----
traceD s t = t traceD s t = t
-- the main function: generate GFCC from GF. -- the main function: generate PGF from GF.
prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String) prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String)
prGrammar2gfcc opts cnc gr = (abs,printGFCC gc) where prGrammar2gfcc opts cnc gr = (abs,printPGF gc) where
(abs,gc) = mkCanon2gfcc opts cnc gr (abs,gc) = mkCanon2gfcc opts cnc gr
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC) mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
mkCanon2gfcc opts cnc gr = mkCanon2gfcc opts cnc gr =
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr) (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
where where
@@ -51,18 +51,18 @@ mkCanon2gfcc opts cnc gr =
pars = mkParamLincat gr pars = mkParamLincat gr
-- Adds parsers for all concretes -- Adds parsers for all concretes
addParsers :: D.GFCC -> D.GFCC addParsers :: D.PGF -> D.PGF
addParsers gfcc = gfcc { D.concretes = Map.map conv (D.concretes gfcc) } addParsers pgf = pgf { D.concretes = Map.map conv (D.concretes pgf) }
where where
conv cnc = cnc { D.parser = Just (buildParserInfo (convertConcrete (D.abstract gfcc) cnc)) } conv cnc = cnc { D.parser = Just (buildParserInfo (convertConcrete (D.abstract pgf) cnc)) }
-- Generate GFCC from GFCM. -- Generate PGF from GFCM.
-- this assumes a grammar translated by canon2canon -- this assumes a grammar translated by canon2canon
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.GFCC canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
(if dump opts DumpCanon then trace (prGrammar cgr) else id) $ (if dump opts DumpCanon then trace (prGrammar cgr) else id) $
D.GFCC an cns gflags abs cncs D.PGF an cns gflags abs cncs
where where
-- abstract -- abstract
an = (i2i a) an = (i2i a)
@@ -176,7 +176,7 @@ mkTerm tr = case tr of
C.S ts -> concatMap flats ts C.S ts -> concatMap flats ts
_ -> [t] _ -> [t]
-- encoding GFCC-internal lincats as terms -- encoding PGF-internal lincats as terms
mkCType :: Type -> C.Term mkCType :: Type -> C.Term
mkCType t = case t of mkCType t = case t of
EInt i -> C.C $ fromInteger i EInt i -> C.C $ fromInteger i

16
src-3.0/GF/Compile/OptimizeGFCC.hs
View File

@@ -12,12 +12,12 @@ import qualified Data.Map as Map
-- back-end optimization: -- back-end optimization:
-- suffix analysis followed by common subexpression elimination -- suffix analysis followed by common subexpression elimination
optGFCC :: GFCC -> GFCC optPGF :: PGF -> PGF
optGFCC = cseOptimize . suffixOptimize optPGF = cseOptimize . suffixOptimize
suffixOptimize :: GFCC -> GFCC suffixOptimize :: PGF -> PGF
suffixOptimize gfcc = gfcc { suffixOptimize pgf = pgf {
concretes = Map.map opt (concretes gfcc) concretes = Map.map opt (concretes pgf)
} }
where where
opt cnc = cnc { opt cnc = cnc {
@@ -26,9 +26,9 @@ suffixOptimize gfcc = gfcc {
printnames = Map.map optTerm (printnames cnc) printnames = Map.map optTerm (printnames cnc)
} }
cseOptimize :: GFCC -> GFCC cseOptimize :: PGF -> PGF
cseOptimize gfcc = gfcc { cseOptimize pgf = pgf {
concretes = Map.map subex (concretes gfcc) concretes = Map.map subex (concretes pgf)
} }
-- analyse word form lists into prefix + suffixes -- analyse word form lists into prefix + suffixes

10
src-3.0/GF/Infra/Option.hs
View File

@@ -73,7 +73,7 @@ data Phase = Preproc | Convert | Compile | Link
data Encoding = UTF_8 | ISO_8859_1 data Encoding = UTF_8 | ISO_8859_1
deriving (Show,Eq,Ord) deriving (Show,Eq,Ord)
data OutputFormat = FmtGFCC | FmtJavaScript | FmtHaskell | FmtHaskellGADT data OutputFormat = FmtPGF | FmtJavaScript | FmtHaskell | FmtHaskellGADT
deriving (Eq,Ord) deriving (Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
@@ -252,7 +252,7 @@ defaultFlags = Flags {
optShowCPUTime = False, optShowCPUTime = False,
optEmitGFO = True, optEmitGFO = True,
optGFODir = ".", optGFODir = ".",
optOutputFormats = [FmtGFCC], optOutputFormats = [FmtPGF],
optOutputFile = Nothing, optOutputFile = Nothing,
optOutputDir = Nothing, optOutputDir = Nothing,
optRecomp = RecompIfNewer, optRecomp = RecompIfNewer,
@@ -344,7 +344,7 @@ optDescr =
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
Option [] ["make"] (NoArg (phase Link)) "Build .gfcc file and other output files.", Option [] ["make"] (NoArg (phase Link)) "Build .pgf file and other output files.",
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.", Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).", Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).", Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).",
@@ -352,7 +352,7 @@ optDescr =
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:",
"Multiple concrete: gfcc (default), gar, js, ...", "Multiple concrete: pgf (default), gar, js, ...",
"Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
"Abstract only: haskell, ..."]), "Abstract only: haskell, ..."]),
Option ['o'] ["output-file"] (ReqArg outFile "FILE") Option ['o'] ["output-file"] (ReqArg outFile "FILE")
@@ -392,7 +392,7 @@ optDescr =
outputFormats :: [(String,OutputFormat)] outputFormats :: [(String,OutputFormat)]
outputFormats = outputFormats =
[("gfcc", FmtGFCC), [("pgf", FmtPGF),
("js", FmtJavaScript), ("js", FmtJavaScript),
("haskell", FmtHaskell), ("haskell", FmtHaskell),
("haskell_gadt", FmtHaskellGADT)] ("haskell_gadt", FmtHaskellGADT)]

18
src-3.0/GFC.hs
View File

@@ -22,16 +22,16 @@ mainGFC opts fs =
let cnc = justModuleName (last fs) let cnc = justModuleName (last fs)
if flag optStopAfterPhase opts == Compile if flag optStopAfterPhase opts == Compile
then return () then return ()
else do gfcc <- link opts cnc gr else do pgf <- link opts cnc gr
writeOutputs opts gfcc writeOutputs opts pgf
writeOutputs :: Options -> GFCC -> IOE () writeOutputs :: Options -> PGF -> IOE ()
writeOutputs opts gfcc = mapM_ (\fmt -> writeOutput opts fmt gfcc) (flag optOutputFormats opts) writeOutputs opts pgf = mapM_ (\fmt -> writeOutput opts fmt pgf) (flag optOutputFormats opts)
writeOutput :: Options -> OutputFormat-> GFCC -> IOE () writeOutput :: Options -> OutputFormat-> PGF -> IOE ()
writeOutput opts fmt gfcc = writeOutput opts fmt pgf =
do let path = outputFilePath opts fmt (prCId (absname gfcc)) do let path = outputFilePath opts fmt (prCId (absname pgf))
s = prGFCC fmt gfcc s = prPGF fmt pgf
writeOutputFile path s writeOutputFile path s
outputFilePath :: Options -> OutputFormat -> String -> FilePath outputFilePath :: Options -> OutputFormat -> String -> FilePath
@@ -40,7 +40,7 @@ outputFilePath opts fmt name0 = addDir name <.> fmtExtension fmt
addDir = maybe id (</>) (flag optOutputDir opts) addDir = maybe id (</>) (flag optOutputDir opts)
fmtExtension :: OutputFormat -> String fmtExtension :: OutputFormat -> String
fmtExtension FmtGFCC = "gfcc" fmtExtension FmtPGF = "pgf"
fmtExtension FmtJavaScript = "js" fmtExtension FmtJavaScript = "js"
fmtExtension FmtHaskell = "hs" fmtExtension FmtHaskell = "hs"
fmtExtension FmtHaskellGADT = "hs" fmtExtension FmtHaskellGADT = "hs"

18
src-3.0/GFI.hs
View File

@@ -19,7 +19,7 @@ import Paths_gf
mainGFI :: Options -> [FilePath] -> IO () mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do mainGFI opts files = do
putStrLn welcome putStrLn welcome
env <- importInEnv emptyMultiGrammar opts files env <- importInEnv emptyPGF opts files
loop (GFEnv emptyGrammar env [] 0) loop (GFEnv emptyGrammar env [] 0)
return () return ()
@@ -50,7 +50,7 @@ loop gfenv0 = do
loopNewCPU gfenv loopNewCPU gfenv
-- other special commands, working on GFEnv -- other special commands, working on GFEnv
"e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyMultiGrammar}} "e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyPGF}}
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
"q":_ -> putStrLn "See you." >> return gfenv "q":_ -> putStrLn "See you." >> return gfenv
@@ -64,13 +64,13 @@ loopNewCPU gfenv = do
putStrLn (show ((cpu' - cputime gfenv) `div` 1000000000) ++ " msec") putStrLn (show ((cpu' - cputime gfenv) `div` 1000000000) ++ " msec")
loop $ gfenv {cputime = cpu'} loop $ gfenv {cputime = cpu'}
importInEnv :: MultiGrammar -> Options -> [FilePath] -> IO CommandEnv importInEnv :: PGF -> Options -> [FilePath] -> IO CommandEnv
importInEnv mgr0 opts files = do importInEnv pgf0 opts files = do
mgr1 <- case files of pgf1 <- case files of
[] -> return mgr0 [] -> return pgf0
_ -> importGrammar mgr0 opts files _ -> importGrammar pgf0 opts files
let env = CommandEnv mgr1 (allCommands mgr1) let env = CommandEnv pgf1 (allCommands pgf1)
putStrLn $ unwords $ "\nLanguages:" : languages mgr1 putStrLn $ unwords $ "\nLanguages:" : languages pgf1
return env return env
welcome = unlines [ welcome = unlines [

60
src-3.0/PGF.hs
View File

@@ -13,7 +13,7 @@
-- embedded GF systems. AR 19/9/2007 -- embedded GF systems. AR 19/9/2007
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module PGF where module PGF(module PGF, PGF, emptyPGF) where
import PGF.CId import PGF.CId
import PGF.Linearize import PGF.Linearize
@@ -43,51 +43,46 @@ import qualified Text.ParserCombinators.ReadP as RP
-- Interface -- Interface
--------------------------------------------------- ---------------------------------------------------
data MultiGrammar = MultiGrammar {gfcc :: GFCC}
type Language = String type Language = String
type Category = String type Category = String
type Tree = Exp type Tree = Exp
file2grammar :: FilePath -> IO MultiGrammar file2pgf :: FilePath -> IO PGF
linearize :: MultiGrammar -> Language -> Tree -> String linearize :: PGF -> Language -> Tree -> String
parse :: MultiGrammar -> Language -> Category -> String -> [Tree] parse :: PGF -> Language -> Category -> String -> [Tree]
linearizeAll :: MultiGrammar -> Tree -> [String] linearizeAll :: PGF -> Tree -> [String]
linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)] linearizeAllLang :: PGF -> Tree -> [(Language,String)]
parseAll :: MultiGrammar -> Category -> String -> [[Tree]] parseAll :: PGF -> Category -> String -> [[Tree]]
parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])] parseAllLang :: PGF -> Category -> String -> [(Language,[Tree])]
generateAll :: MultiGrammar -> Category -> [Tree] generateAll :: PGF -> Category -> [Tree]
generateRandom :: MultiGrammar -> Category -> IO [Tree] generateRandom :: PGF -> Category -> IO [Tree]
generateAllDepth :: MultiGrammar -> Category -> Maybe Int -> [Tree] generateAllDepth :: PGF -> Category -> Maybe Int -> [Tree]
readTree :: String -> Tree readTree :: String -> Tree
showTree :: Tree -> String showTree :: Tree -> String
languages :: MultiGrammar -> [Language] languages :: PGF -> [Language]
categories :: MultiGrammar -> [Category] categories :: PGF -> [Category]
startCat :: MultiGrammar -> Category startCat :: PGF -> Category
--------------------------------------------------- ---------------------------------------------------
-- Implementation -- Implementation
--------------------------------------------------- ---------------------------------------------------
file2grammar f = do file2pgf f = do
gfcc <- file2gfcc f
return (MultiGrammar gfcc)
file2gfcc f = do
s <- readFileIf f s <- readFileIf f
g <- parseGrammar s g <- parseGrammar s
return $ toGFCC g return $! toPGF g
linearize mgr lang = PGF.Linearize.linearize (gfcc mgr) (mkCId lang) linearize pgf lang = PGF.Linearize.linearize pgf (mkCId lang)
parse mgr lang cat s = parse pgf lang cat s =
case lookParser (gfcc mgr) (mkCId lang) of case lookParser pgf (mkCId lang) of
Nothing -> error "no parser" Nothing -> error "no parser"
Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
Ok x -> x Ok x -> x
@@ -102,12 +97,12 @@ parseAll mgr cat = map snd . parseAllLang mgr cat
parseAllLang mgr cat s = parseAllLang mgr cat s =
[(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)] [(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)]
generateRandom mgr cat = do generateRandom pgf cat = do
gen <- newStdGen gen <- newStdGen
return $ genRandom gen (gfcc mgr) (mkCId cat) return $ genRandom gen pgf (mkCId cat)
generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing generateAll pgf cat = generate pgf (mkCId cat) Nothing
generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat) generateAllDepth pgf cat = generate pgf (mkCId cat)
readTree s = case RP.readP_to_S (pExp False) s of readTree s = case RP.readP_to_S (pExp False) s of
[(x,"")] -> x [(x,"")] -> x
@@ -158,15 +153,14 @@ ppExp isNested (EVar id) = PP.text (prCId id)
ppParens True = PP.parens ppParens True = PP.parens
ppParens False = id ppParens False = id
abstractName mgr = prCId (absname (gfcc mgr)) abstractName pgf = prCId (absname pgf)
languages mgr = [prCId l | l <- cncnames (gfcc mgr)] languages pgf = [prCId l | l <- cncnames pgf]
categories mgr = [prCId c | c <- Map.keys (cats (abstract (gfcc mgr)))] categories pgf = [prCId c | c <- Map.keys (cats (abstract pgf))]
startCat mgr = lookStartCat (gfcc mgr) startCat pgf = lookStartCat pgf
emptyMultiGrammar = MultiGrammar emptyGFCC
------------ for internal use only ------------ for internal use only

53
src-3.0/PGF/Check.hs
View File

@@ -1,4 +1,4 @@
module PGF.Check (checkGFCC, checkGFCCio, checkGFCCmaybe) where module PGF.Check (checkPGF) where
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
@@ -9,26 +9,11 @@ import qualified Data.Map as Map
import Control.Monad import Control.Monad
import Debug.Trace import Debug.Trace
checkGFCCio :: GFCC -> IO GFCC checkPGF :: PGF -> Err (PGF,Bool)
checkGFCCio gfcc = case checkGFCC gfcc of checkPGF pgf = do
Ok (gc,b) -> do (cs,bs) <- mapM (checkConcrete pgf)
putStrLn $ if b then "OK" else "Corrupted GFCC" (Map.assocs (concretes pgf)) >>= return . unzip
return gc return (pgf {concretes = Map.fromAscList cs}, and bs)
Bad s -> do
putStrLn s
error "building GFCC failed"
---- needed in old Custom
checkGFCCmaybe :: GFCC -> Maybe GFCC
checkGFCCmaybe gfcc = case checkGFCC gfcc of
Ok (gc,b) -> return gc
Bad s -> Nothing
checkGFCC :: GFCC -> Err (GFCC,Bool)
checkGFCC gfcc = do
(cs,bs) <- mapM (checkConcrete gfcc)
(Map.assocs (concretes gfcc)) >>= return . unzip
return (gfcc {concretes = Map.fromAscList cs}, and bs)
-- errors are non-fatal; replace with 'fail' to change this -- errors are non-fatal; replace with 'fail' to change this
@@ -43,18 +28,18 @@ labelBoolErr ms iob = do
if b then return (x,b) else (msg ms >> return (x,b)) if b then return (x,b) else (msg ms >> return (x,b))
checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool) checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool)
checkConcrete gfcc (lang,cnc) = checkConcrete pgf (lang,cnc) =
labelBoolErr ("happened in language " ++ prCId lang) $ do labelBoolErr ("happened in language " ++ prCId lang) $ do
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
return ((lang,cnc{lins = Map.fromAscList rs}),and bs) return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
where where
checkl = checkLin gfcc lang checkl = checkLin pgf lang
checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool) checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
checkLin gfcc lang (f,t) = checkLin pgf lang (f,t) =
labelBoolErr ("happened in function " ++ prCId f) $ do labelBoolErr ("happened in function " ++ prCId f) $ do
(t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t
return ((f,t'),b) return ((f,t'),b)
inferTerm :: [CType] -> Term -> Err (Term,CType) inferTerm :: [CType] -> Term -> Err (Term,CType)
@@ -137,22 +122,22 @@ ints = C
str :: CType str :: CType
str = S [] str = S []
lintype :: GFCC -> CId -> CId -> LinType lintype :: PGF -> CId -> CId -> LinType
lintype gfcc lang fun = case typeSkeleton (lookType gfcc fun) of lintype pgf lang fun = case typeSkeleton (lookType pgf fun) of
(cs,c) -> (map vlinc cs, linc c) ---- HOAS (cs,c) -> (map vlinc cs, linc c) ---- HOAS
where where
linc = lookLincat gfcc lang linc = lookLincat pgf lang
vlinc (0,c) = linc c vlinc (0,c) = linc c
vlinc (i,c) = case linc c of vlinc (i,c) = case linc c of
R ts -> R (ts ++ replicate i str) R ts -> R (ts ++ replicate i str)
inline :: GFCC -> CId -> Term -> Term inline :: PGF -> CId -> Term -> Term
inline gfcc lang t = case t of inline pgf lang t = case t of
F c -> inl $ look c F c -> inl $ look c
_ -> composSafeOp inl t _ -> composSafeOp inl t
where where
inl = inline gfcc lang inl = inline pgf lang
look = lookLin gfcc lang look = lookLin pgf lang
composOp :: Monad m => (Term -> m Term) -> Term -> m Term composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp f trm = case trm of composOp f trm = case trm of

28
src-3.0/PGF/Data.hs
View File

@@ -8,9 +8,9 @@ import qualified Data.Map as Map
import Data.List import Data.List
import Data.Array import Data.Array
-- internal datatypes for GFCC -- internal datatypes for PGF
data GFCC = GFCC { data PGF = PGF {
absname :: CId , absname :: CId ,
cncnames :: [CId] , cncnames :: [CId] ,
gflags :: Map.Map CId String, -- value of a global flag gflags :: Map.Map CId String, -- value of a global flag
@@ -120,17 +120,17 @@ fcatVar = (-4)
-- print statistics -- print statistics
statGFCC :: GFCC -> String statGFCC :: PGF -> String
statGFCC gfcc = unlines [ statGFCC pgf = unlines [
"Abstract\t" ++ prCId (absname gfcc), "Abstract\t" ++ prCId (absname pgf),
"Concretes\t" ++ unwords (map prCId (cncnames gfcc)), "Concretes\t" ++ unwords (map prCId (cncnames pgf)),
"Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract gfcc)))) "Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract pgf))))
] ]
-- merge two GFCCs; fails is differens absnames; priority to second arg -- merge two GFCCs; fails is differens absnames; priority to second arg
unionGFCC :: GFCC -> GFCC -> GFCC unionPGF :: PGF -> PGF -> PGF
unionGFCC one two = case absname one of unionPGF one two = case absname one of
n | n == wildCId -> two -- extending empty grammar n | n == wildCId -> two -- extending empty grammar
| n == absname two -> one { -- extending grammar with same abstract | n == absname two -> one { -- extending grammar with same abstract
concretes = Map.union (concretes two) (concretes one), concretes = Map.union (concretes two) (concretes one),
@@ -138,8 +138,8 @@ unionGFCC one two = case absname one of
} }
_ -> one -- abstracts don't match ---- print error msg _ -> one -- abstracts don't match ---- print error msg
emptyGFCC :: GFCC emptyPGF :: PGF
emptyGFCC = GFCC { emptyPGF = PGF {
absname = wildCId, absname = wildCId,
cncnames = [] , cncnames = [] ,
gflags = Map.empty, gflags = Map.empty,
@@ -149,9 +149,9 @@ emptyGFCC = GFCC {
-- encode idenfifiers and strings in UTF8 -- encode idenfifiers and strings in UTF8
utf8GFCC :: GFCC -> GFCC utf8GFCC :: PGF -> PGF
utf8GFCC gfcc = gfcc { utf8GFCC pgf = pgf {
concretes = Map.map u8concr (concretes gfcc) concretes = Map.map u8concr (concretes pgf)
} }
where where
u8concr cnc = cnc { u8concr cnc = cnc {

20
src-3.0/PGF/Generate.hs
View File

@@ -8,8 +8,8 @@ import qualified Data.Map as M
import System.Random import System.Random
-- generate an infinite list of trees exhaustively -- generate an infinite list of trees exhaustively
generate :: GFCC -> CId -> Maybe Int -> [Exp] generate :: PGF -> CId -> Maybe Int -> [Exp]
generate gfcc cat dp = concatMap (\i -> gener i cat) depths generate pgf cat dp = concatMap (\i -> gener i cat) depths
where where
gener 0 c = [EApp f [] | (f, ([],_)) <- fns c] gener 0 c = [EApp f [] | (f, ([],_)) <- fns c]
gener i c = [ gener i c = [
@@ -20,12 +20,12 @@ generate gfcc cat dp = concatMap (\i -> gener i cat) depths
let tr = EApp f ts, let tr = EApp f ts,
depth tr >= i depth tr >= i
] ]
fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat gfcc c] fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c]
depths = maybe [0 ..] (\d -> [0..d]) dp depths = maybe [0 ..] (\d -> [0..d]) dp
-- generate an infinite list of trees randomly -- generate an infinite list of trees randomly
genRandom :: StdGen -> GFCC -> CId -> [Exp] genRandom :: StdGen -> PGF -> CId -> [Exp]
genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
timeout = 47 -- give up timeout = 47 -- give up
@@ -55,7 +55,7 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
in (t:ts, k + ks) in (t:ts, k + ks)
_ -> ([],0) _ -> ([],0)
fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat gfcc cat] fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat pgf cat]
{- {-
@@ -63,8 +63,8 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
-- note: you cannot throw away rules with unknown words from the grammar -- note: you cannot throw away rules with unknown words from the grammar
-- because it is not known which field in each rule may match the input -- because it is not known which field in each rule may match the input
searchParse :: Int -> GFCC -> CId -> [String] -> [Exp] searchParse :: Int -> PGF -> CId -> [String] -> [Exp]
searchParse i gfcc cat ws = [t | t <- gen, s <- lins t, words s == ws] where searchParse i pgf cat ws = [t | t <- gen, s <- lins t, words s == ws] where
gen = take i $ generate gfcc cat gen = take i $ generate pgf cat
lins t = [linearize gfcc lang t | lang <- cncnames gfcc] lins t = [linearize pgf lang t | lang <- cncnames pgf]
-} -}

20
src-3.0/PGF/Linearize.hs
View File

@@ -8,10 +8,10 @@ import Data.List
import Debug.Trace import Debug.Trace
-- linearization and computation of concrete GFCC Terms -- linearization and computation of concrete PGF Terms
linearize :: GFCC -> CId -> Exp -> String linearize :: PGF -> CId -> Exp -> String
linearize mcfg lang = realize . linExp mcfg lang linearize pgf lang = realize . linExp pgf lang
realize :: Term -> String realize :: Term -> String
realize trm = case trm of realize trm = case trm of
@@ -25,8 +25,8 @@ realize trm = case trm of
TM s -> s TM s -> s
_ -> "ERROR " ++ show trm ---- debug _ -> "ERROR " ++ show trm ---- debug
linExp :: GFCC -> CId -> Exp -> Term linExp :: PGF -> CId -> Exp -> Term
linExp gfcc lang = lin linExp pgf lang = lin
where where
lin (EAbs xs e ) = case lin e of lin (EAbs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
@@ -38,12 +38,12 @@ linExp gfcc lang = lin
lin (EVar x ) = TM (prCId x) lin (EVar x ) = TM (prCId x)
lin (EMeta i ) = TM (show i) lin (EMeta i ) = TM (show i)
comp = compute gfcc lang comp = compute pgf lang
look = lookLin gfcc lang look = lookLin pgf lang
compute :: GFCC -> CId -> [Term] -> Term -> Term compute :: PGF -> CId -> [Term] -> Term -> Term
compute mcfg lang args = comp where compute pgf lang args = comp where
comp trm = case trm of comp trm = case trm of
P r p -> proj (comp r) (comp p) P r p -> proj (comp r) (comp p)
W s t -> W s (comp t) W s t -> W s (comp t)
@@ -54,7 +54,7 @@ compute mcfg lang args = comp where
S ts -> S $ filter (/= S []) $ map comp ts S ts -> S $ filter (/= S []) $ map comp ts
_ -> trm _ -> trm
look = lookOper mcfg lang look = lookOper pgf lang
idx xs i = if i > length xs - 1 idx xs i = if i > length xs - 1
then trace then trace

72
src-3.0/PGF/Macros.hs
View File

@@ -8,58 +8,58 @@ import qualified Data.Array as Array
import Data.Maybe import Data.Maybe
import Data.List import Data.List
-- operations for manipulating GFCC grammars and objects -- operations for manipulating PGF grammars and objects
lookLin :: GFCC -> CId -> CId -> Term lookLin :: PGF -> CId -> CId -> Term
lookLin gfcc lang fun = lookLin pgf lang fun =
lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes pgf
lookOper :: GFCC -> CId -> CId -> Term lookOper :: PGF -> CId -> CId -> Term
lookOper gfcc lang fun = lookOper pgf lang fun =
lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes pgf
lookLincat :: GFCC -> CId -> CId -> Term lookLincat :: PGF -> CId -> CId -> Term
lookLincat gfcc lang fun = lookLincat pgf lang fun =
lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes pgf
lookParamLincat :: GFCC -> CId -> CId -> Term lookParamLincat :: PGF -> CId -> CId -> Term
lookParamLincat gfcc lang fun = lookParamLincat pgf lang fun =
lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes pgf
lookType :: GFCC -> CId -> Type lookType :: PGF -> CId -> Type
lookType gfcc f = lookType pgf f =
fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc)) fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf))
lookParser :: GFCC -> CId -> Maybe ParserInfo lookParser :: PGF -> CId -> Maybe ParserInfo
lookParser gfcc lang = parser $ lookMap (error "no lang") lang $ concretes gfcc lookParser pgf lang = parser $ lookMap (error "no lang") lang $ concretes pgf
lookFCFG :: GFCC -> CId -> Maybe FGrammar lookFCFG :: PGF -> CId -> Maybe FGrammar
lookFCFG gfcc lang = fmap toFGrammar $ lookParser gfcc lang lookFCFG pgf lang = fmap toFGrammar $ lookParser pgf lang
where where
toFGrammar :: ParserInfo -> FGrammar toFGrammar :: ParserInfo -> FGrammar
toFGrammar pinfo = (Array.elems (allRules pinfo), startupCats pinfo) toFGrammar pinfo = (Array.elems (allRules pinfo), startupCats pinfo)
lookStartCat :: GFCC -> String lookStartCat :: PGF -> String
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat")) lookStartCat pgf = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
[gflags gfcc, aflags (abstract gfcc)] [gflags pgf, aflags (abstract pgf)]
lookGlobalFlag :: GFCC -> CId -> String lookGlobalFlag :: PGF -> CId -> String
lookGlobalFlag gfcc f = lookGlobalFlag pgf f =
lookMap "?" f (gflags gfcc) lookMap "?" f (gflags pgf)
lookAbsFlag :: GFCC -> CId -> String lookAbsFlag :: PGF -> CId -> String
lookAbsFlag gfcc f = lookAbsFlag pgf f =
lookMap "?" f (aflags (abstract gfcc)) lookMap "?" f (aflags (abstract pgf))
lookCncFlag :: GFCC -> CId -> CId -> String lookCncFlag :: PGF -> CId -> CId -> String
lookCncFlag gfcc lang f = lookCncFlag pgf lang f =
lookMap "?" f $ cflags $ lookMap (error "no lang") lang $ concretes gfcc lookMap "?" f $ cflags $ lookMap (error "no lang") lang $ concretes pgf
functionsToCat :: GFCC -> CId -> [(CId,Type)] functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat gfcc cat = functionsToCat pgf cat =
[(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract gfcc]] [(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract pgf]]
where where
fs = lookMap [] cat $ catfuns $ abstract gfcc fs = lookMap [] cat $ catfuns $ abstract pgf
depth :: Exp -> Int depth :: Exp -> Int
depth (EAbs _ t) = depth t depth (EAbs _ t) = depth t

28
src-3.0/PGF/Raw/Convert.hs
View File

@@ -1,4 +1,4 @@
module PGF.Raw.Convert (toGFCC,fromGFCC) where module PGF.Raw.Convert (toPGF,fromPGF) where
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
@@ -12,10 +12,10 @@ import qualified Data.Map as Map
pgfMajorVersion, pgfMinorVersion :: Integer pgfMajorVersion, pgfMinorVersion :: Integer
(pgfMajorVersion, pgfMinorVersion) = (1,0) (pgfMajorVersion, pgfMinorVersion) = (1,0)
-- convert parsed grammar to internal GFCC -- convert parsed grammar to internal PGF
toGFCC :: Grammar -> GFCC toPGF :: Grammar -> PGF
toGFCC (Grm [ toPGF (Grm [
App "pgf" (AInt v1 : AInt v2 : App a []:cs), App "pgf" (AInt v1 : AInt v2 : App a []:cs),
App "flags" gfs, App "flags" gfs,
ab@( ab@(
@@ -24,7 +24,7 @@ toGFCC (Grm [
App "cat" cts App "cat" cts
]), ]),
App "concrete" ccs App "concrete" ccs
]) = GFCC { ]) = PGF {
absname = mkCId a, absname = mkCId a,
cncnames = [mkCId c | App c [] <- cs], cncnames = [mkCId c | App c [] <- cs],
gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs], gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
@@ -135,20 +135,20 @@ toTerm e = case e of
--- from internal to parser -- --- from internal to parser --
------------------------------ ------------------------------
fromGFCC :: GFCC -> Grammar fromPGF :: PGF -> Grammar
fromGFCC gfcc0 = Grm [ fromPGF pgf0 = Grm [
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
: App (prCId (absname gfcc)) [] : map (flip App [] . prCId) (cncnames gfcc)), : App (prCId (absname pgf)) [] : map (flip App [] . prCId) (cncnames pgf)),
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags gfcc `Map.union` aflags agfcc)], App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags pgf `Map.union` aflags apgf)],
App "abstract" [ App "abstract" [
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs agfcc)], App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs apgf)],
App "cat" [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats agfcc)] App "cat" [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats apgf)]
], ],
App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes gfcc)] App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes pgf)]
] ]
where where
gfcc = utf8GFCC gfcc0 pgf = utf8GFCC pgf0
agfcc = abstract gfcc apgf = abstract pgf
fromConcrete cnc = [ fromConcrete cnc = [
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (cflags cnc)], App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (cflags cnc)],
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)], App "lin" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)],

30
src-3.0/PGF/ShowLinearize.hs
View File

@@ -37,7 +37,7 @@ prRecord = prr where
RS s -> prQuotedString s RS s -> prQuotedString s
RCon s -> s RCon s -> s
-- uses the encoding of record types in GFCC.paramlincat -- uses the encoding of record types in PGF.paramlincat
mkRecord :: Term -> Term -> Record mkRecord :: Term -> Term -> Record
mkRecord typ trm = case (typ,trm) of mkRecord typ trm = case (typ,trm) of
(R rs, R ts) -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts] (R rs, R ts) -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts]
@@ -50,18 +50,18 @@ mkRecord typ trm = case (typ,trm) of
str = realize str = realize
-- show all branches, without labels and params -- show all branches, without labels and params
allLinearize :: GFCC -> CId -> Exp -> String allLinearize :: PGF -> CId -> Exp -> String
allLinearize gfcc lang = concat . map pr . tabularLinearize gfcc lang where allLinearize pgf lang = concat . map pr . tabularLinearize pgf lang where
pr (p,vs) = unlines vs pr (p,vs) = unlines vs
-- show all branches, with labels and params -- show all branches, with labels and params
tableLinearize :: GFCC -> CId -> Exp -> String tableLinearize :: PGF -> CId -> Exp -> String
tableLinearize gfcc lang = unlines . map pr . tabularLinearize gfcc lang where tableLinearize pgf lang = unlines . map pr . tabularLinearize pgf lang where
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs) pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs)
-- create a table from labels+params to variants -- create a table from labels+params to variants
tabularLinearize :: GFCC -> CId -> Exp -> [(String,[String])] tabularLinearize :: PGF -> CId -> Exp -> [(String,[String])]
tabularLinearize gfcc lang = branches . recLinearize gfcc lang where tabularLinearize pgf lang = branches . recLinearize pgf lang where
branches r = case r of branches r = case r of
RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t] RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
RT fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t] RT fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
@@ -70,17 +70,17 @@ tabularLinearize gfcc lang = branches . recLinearize gfcc lang where
RCon _ -> [] RCon _ -> []
-- show record in GF-source-like syntax -- show record in GF-source-like syntax
recordLinearize :: GFCC -> CId -> Exp -> String recordLinearize :: PGF -> CId -> Exp -> String
recordLinearize gfcc lang = prRecord . recLinearize gfcc lang recordLinearize pgf lang = prRecord . recLinearize pgf lang
-- create a GF-like record, forming the basis of all functions above -- create a GF-like record, forming the basis of all functions above
recLinearize :: GFCC -> CId -> Exp -> Record recLinearize :: PGF -> CId -> Exp -> Record
recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where recLinearize pgf lang exp = mkRecord typ $ linExp pgf lang exp where
typ = case exp of typ = case exp of
EApp f _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f EApp f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-- show GFCC term -- show PGF term
termLinearize :: GFCC -> CId -> Exp -> String termLinearize :: PGF -> CId -> Exp -> String
termLinearize gfcc lang = show . linExp gfcc lang termLinearize pgf lang = show . linExp pgf lang