mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-12 22:39:31 -06:00
replace GFCC with PGF in (almost) all places
This commit is contained in:
krasimir
@@ -47,10 +47,10 @@ emptyCommandInfo = CommandInfo {
|
||||
lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
|
||||
lookCommand = Map.lookup
|
||||
|
||||
commandHelpAll :: MultiGrammar -> [Option] -> String
|
||||
commandHelpAll mgr opts = unlines
|
||||
commandHelpAll :: PGF -> [Option] -> String
|
||||
commandHelpAll pgf opts = unlines
|
||||
[commandHelp (isOpt "full" opts) (co,info)
|
||||
| (co,info) <- Map.assocs (allCommands mgr)]
|
||||
| (co,info) <- Map.assocs (allCommands pgf)]
|
||||
|
||||
commandHelp :: Bool -> (String,CommandInfo) -> String
|
||||
commandHelp full (co,info) = unlines $ [
|
||||
@@ -82,14 +82,14 @@ isOpt :: String -> [Option] -> Bool
|
||||
isOpt o opts = elem o [x | OOpt (Ident x) <- opts]
|
||||
|
||||
-- this list must be kept sorted by the command name!
|
||||
allCommands :: MultiGrammar -> Map.Map String CommandInfo
|
||||
allCommands mgr = Map.fromAscList [
|
||||
allCommands :: PGF -> Map.Map String CommandInfo
|
||||
allCommands pgf = Map.fromAscList [
|
||||
("gr", emptyCommandInfo {
|
||||
longname = "generate_random",
|
||||
synopsis = "generates a list of random trees, by default one tree",
|
||||
flags = ["cat","number"],
|
||||
exec = \opts _ -> do
|
||||
ts <- generateRandom mgr (optCat opts)
|
||||
ts <- generateRandom pgf (optCat opts)
|
||||
return $ fromTrees $ take (optNum opts) ts
|
||||
}),
|
||||
("gt", emptyCommandInfo {
|
||||
@@ -98,7 +98,7 @@ allCommands mgr = Map.fromAscList [
|
||||
flags = ["cat","depth","number"],
|
||||
exec = \opts _ -> do
|
||||
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
|
||||
}),
|
||||
("h", emptyCommandInfo {
|
||||
@@ -107,10 +107,10 @@ allCommands mgr = Map.fromAscList [
|
||||
options = ["full"],
|
||||
exec = \opts ts -> return ([], case ts of
|
||||
[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)
|
||||
_ -> "command not found"
|
||||
_ -> commandHelpAll mgr opts)
|
||||
_ -> commandHelpAll pgf opts)
|
||||
}),
|
||||
("l", emptyCommandInfo {
|
||||
exec = \opts -> return . fromStrings . map (optLin opts),
|
||||
@@ -127,33 +127,31 @@ allCommands mgr = Map.fromAscList [
|
||||
})
|
||||
]
|
||||
where
|
||||
lin opts t = unlines [linearize mgr lang t | lang <- optLangs opts]
|
||||
par opts s = concat [parse mgr lang (optCat opts) s | lang <- optLangs opts]
|
||||
lin opts t = unlines [linearize pgf lang t | 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
|
||||
linea lang = case opts of
|
||||
_ | isOpt "all" opts -> allLinearize gr (mkCId lang)
|
||||
_ | isOpt "table" opts -> tableLinearize gr (mkCId lang)
|
||||
_ | isOpt "term" opts -> termLinearize gr (mkCId lang)
|
||||
_ | isOpt "record" opts -> recordLinearize gr (mkCId lang)
|
||||
_ -> linearize mgr lang
|
||||
_ | isOpt "all" opts -> allLinearize pgf (mkCId lang)
|
||||
_ | isOpt "table" opts -> tableLinearize pgf (mkCId lang)
|
||||
_ | isOpt "term" opts -> termLinearize pgf (mkCId lang)
|
||||
_ | isOpt "record" opts -> recordLinearize pgf (mkCId lang)
|
||||
_ -> linearize pgf lang
|
||||
|
||||
|
||||
optLangs opts = case valIdOpts "lang" "" opts of
|
||||
"" -> languages mgr
|
||||
"" -> languages pgf
|
||||
lang -> [lang]
|
||||
optCat opts = valIdOpts "cat" (lookStartCat gr) opts
|
||||
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
|
||||
optNum opts = valIntOpts "number" 1 opts
|
||||
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
|
||||
|
||||
gr = gfcc mgr
|
||||
|
||||
fromTrees ts = (ts,unlines (map showTree ts))
|
||||
fromStrings ss = (map EStr ss, unlines ss)
|
||||
fromString s = ([EStr s], s)
|
||||
toStrings ts = [s | EStr s <- ts]
|
||||
|
||||
prGrammar opts = case valIdOpts "printer" "" opts of
|
||||
"cats" -> unwords $ categories mgr
|
||||
v -> prGFCC (read v) gr
|
||||
"cats" -> unwords $ categories pgf
|
||||
v -> prPGF (read v) pgf
|
||||
|
||||
|
||||
@@ -13,20 +13,18 @@ import Data.List (nubBy)
|
||||
import System.FilePath
|
||||
|
||||
-- import a grammar in an environment where it extends an existing grammar
|
||||
importGrammar :: MultiGrammar -> Options -> [FilePath] -> IO MultiGrammar
|
||||
importGrammar mgr0 opts files =
|
||||
importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
|
||||
importGrammar pgf0 opts files =
|
||||
case takeExtensions (last files) of
|
||||
s | elem s [".gf",".gfo"] -> do
|
||||
res <- appIOE $ compileToGFCC opts files
|
||||
res <- appIOE $ compileToPGF opts files
|
||||
case res of
|
||||
Ok gfcc2 -> do let gfcc3 = unionGFCC (gfcc mgr0) gfcc2
|
||||
return $ MultiGrammar gfcc3
|
||||
Bad msg -> do putStrLn msg
|
||||
return mgr0
|
||||
".gfcc" -> do
|
||||
gfcc2 <- mapM file2gfcc files >>= return . foldl1 unionGFCC
|
||||
let gfcc3 = unionGFCC (gfcc mgr0) gfcc2
|
||||
return $ MultiGrammar gfcc3
|
||||
Ok pgf2 -> do return $ unionPGF pgf0 pgf2
|
||||
Bad msg -> do putStrLn msg
|
||||
return pgf0
|
||||
".pgf" -> do
|
||||
pgf2 <- mapM file2pgf files >>= return . foldl1 unionPGF
|
||||
return $ unionPGF pgf0 pgf2
|
||||
|
||||
importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar
|
||||
importSource src0 opts files = do
|
||||
|
||||
@@ -17,7 +17,7 @@ import GF.Data.ErrM ----
|
||||
import qualified Data.Map as Map
|
||||
|
||||
data CommandEnv = CommandEnv {
|
||||
multigrammar :: MultiGrammar,
|
||||
multigrammar :: PGF,
|
||||
commands :: Map.Map String CommandInfo
|
||||
}
|
||||
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module GF.Compile (batchCompile, link, compileToGFCC) where
|
||||
module GF.Compile (batchCompile, link, compileToPGF) where
|
||||
|
||||
-- the main compiler passes
|
||||
import GF.Compile.GetGrammar
|
||||
@@ -39,27 +39,31 @@ import PGF.Check
|
||||
import PGF.Data
|
||||
|
||||
|
||||
-- | Compiles a number of source files and builds a 'GFCC' structure for them.
|
||||
compileToGFCC :: Options -> [FilePath] -> IOE GFCC
|
||||
compileToGFCC opts fs =
|
||||
-- | Compiles a number of source files and builds a 'PGF' structure for them.
|
||||
compileToPGF :: Options -> [FilePath] -> IOE PGF
|
||||
compileToPGF opts fs =
|
||||
do gr <- batchCompile opts fs
|
||||
let name = justModuleName (last fs)
|
||||
link opts name gr
|
||||
|
||||
link :: Options -> String -> SourceGrammar -> IOE GFCC
|
||||
link :: Options -> String -> SourceGrammar -> IOE PGF
|
||||
link opts cnc gr =
|
||||
do gc1 <- putPointE Normal opts "linking ... " $
|
||||
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
|
||||
|
||||
optimize :: Options -> GFCC -> GFCC
|
||||
optimize :: Options -> PGF -> PGF
|
||||
optimize opts = cse . suf
|
||||
where os = moduleFlag optOptimizations opts
|
||||
cse = if OptCSE `elem` os then cseOptimize else id
|
||||
suf = if OptStem `elem` os then suffixOptimize else id
|
||||
|
||||
buildParser :: Options -> GFCC -> GFCC
|
||||
buildParser :: Options -> PGF -> PGF
|
||||
buildParser opts =
|
||||
if moduleFlag optBuildParser opts then addParsers else id
|
||||
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
module GF.Compile.Export where
|
||||
|
||||
import PGF.Data (GFCC)
|
||||
import PGF.Data (PGF)
|
||||
import PGF.Raw.Print (printTree)
|
||||
import PGF.Raw.Convert (fromGFCC)
|
||||
import PGF.Raw.Convert (fromPGF)
|
||||
import GF.Compile.GFCCtoHaskell
|
||||
import GF.Compile.GFCCtoJS
|
||||
import GF.Infra.Option
|
||||
@@ -10,13 +10,13 @@ import GF.Text.UTF8
|
||||
|
||||
-- top-level access to code generation
|
||||
|
||||
prGFCC :: OutputFormat -> GFCC -> String
|
||||
prGFCC fmt gr = case fmt of
|
||||
FmtGFCC -> printGFCC gr
|
||||
FmtJavaScript -> gfcc2js gr
|
||||
prPGF :: OutputFormat -> PGF -> String
|
||||
prPGF fmt gr = case fmt of
|
||||
FmtPGF -> printPGF gr
|
||||
FmtJavaScript -> pgf2js gr
|
||||
FmtHaskell -> grammar2haskell gr
|
||||
FmtHaskellGADT -> grammar2haskellGADT gr
|
||||
|
||||
printGFCC :: GFCC -> String
|
||||
printGFCC = encodeUTF8 . printTree . fromGFCC
|
||||
printPGF :: PGF -> String
|
||||
printPGF = encodeUTF8 . printTree . fromPGF
|
||||
|
||||
|
||||
@@ -27,12 +27,12 @@ import Data.List --(isPrefixOf, find, intersperse)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- | the main function
|
||||
grammar2haskell :: GFCC -> String
|
||||
grammar2haskell :: PGF -> String
|
||||
grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $
|
||||
haskPreamble ++ [datatypes gr', gfinstances gr']
|
||||
where gr' = hSkeleton gr
|
||||
|
||||
grammar2haskellGADT :: GFCC -> String
|
||||
grammar2haskellGADT :: PGF -> String
|
||||
grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $
|
||||
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
|
||||
haskPreamble ++ [datatypesGADT gr', gfinstances gr']
|
||||
@@ -173,7 +173,7 @@ fInstance m (cat,rules) =
|
||||
|
||||
|
||||
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
hSkeleton :: GFCC -> (String,HSkeleton)
|
||||
hSkeleton :: PGF -> (String,HSkeleton)
|
||||
hSkeleton gr =
|
||||
(prCId (absname gr),
|
||||
[(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) |
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module GF.Compile.GFCCtoJS (gfcc2js) where
|
||||
module GF.Compile.GFCCtoJS (pgf2js) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
@@ -16,14 +16,14 @@ import qualified Data.Array as Array
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
gfcc2js :: GFCC -> String
|
||||
gfcc2js gfcc =
|
||||
pgf2js :: PGF -> String
|
||||
pgf2js pgf =
|
||||
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
|
||||
where
|
||||
n = prCId $ absname gfcc
|
||||
as = abstract gfcc
|
||||
cs = Map.assocs (concretes gfcc)
|
||||
start = M.lookStartCat gfcc
|
||||
n = prCId $ absname pgf
|
||||
as = abstract pgf
|
||||
cs = Map.assocs (concretes pgf)
|
||||
start = M.lookStartCat pgf
|
||||
grammar = new "GFGrammar" [js_abstract, js_concrete]
|
||||
js_abstract = abstract2js start as
|
||||
js_concrete = JS.EObj $ map (concrete2js start n) cs
|
||||
|
||||
@@ -37,13 +37,13 @@ import Debug.Trace ----
|
||||
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 opts cnc gr = (abs,printGFCC gc) where
|
||||
prGrammar2gfcc opts cnc gr = (abs,printPGF gc) where
|
||||
(abs,gc) = mkCanon2gfcc opts cnc gr
|
||||
|
||||
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC)
|
||||
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
|
||||
mkCanon2gfcc opts cnc gr =
|
||||
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
|
||||
where
|
||||
@@ -51,18 +51,18 @@ mkCanon2gfcc opts cnc gr =
|
||||
pars = mkParamLincat gr
|
||||
|
||||
-- Adds parsers for all concretes
|
||||
addParsers :: D.GFCC -> D.GFCC
|
||||
addParsers gfcc = gfcc { D.concretes = Map.map conv (D.concretes gfcc) }
|
||||
addParsers :: D.PGF -> D.PGF
|
||||
addParsers pgf = pgf { D.concretes = Map.map conv (D.concretes pgf) }
|
||||
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
|
||||
|
||||
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)) =
|
||||
(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
|
||||
-- abstract
|
||||
an = (i2i a)
|
||||
@@ -176,7 +176,7 @@ mkTerm tr = case tr of
|
||||
C.S ts -> concatMap flats ts
|
||||
_ -> [t]
|
||||
|
||||
-- encoding GFCC-internal lincats as terms
|
||||
-- encoding PGF-internal lincats as terms
|
||||
mkCType :: Type -> C.Term
|
||||
mkCType t = case t of
|
||||
EInt i -> C.C $ fromInteger i
|
||||
|
||||
@@ -12,12 +12,12 @@ import qualified Data.Map as Map
|
||||
-- back-end optimization:
|
||||
-- suffix analysis followed by common subexpression elimination
|
||||
|
||||
optGFCC :: GFCC -> GFCC
|
||||
optGFCC = cseOptimize . suffixOptimize
|
||||
optPGF :: PGF -> PGF
|
||||
optPGF = cseOptimize . suffixOptimize
|
||||
|
||||
suffixOptimize :: GFCC -> GFCC
|
||||
suffixOptimize gfcc = gfcc {
|
||||
concretes = Map.map opt (concretes gfcc)
|
||||
suffixOptimize :: PGF -> PGF
|
||||
suffixOptimize pgf = pgf {
|
||||
concretes = Map.map opt (concretes pgf)
|
||||
}
|
||||
where
|
||||
opt cnc = cnc {
|
||||
@@ -26,9 +26,9 @@ suffixOptimize gfcc = gfcc {
|
||||
printnames = Map.map optTerm (printnames cnc)
|
||||
}
|
||||
|
||||
cseOptimize :: GFCC -> GFCC
|
||||
cseOptimize gfcc = gfcc {
|
||||
concretes = Map.map subex (concretes gfcc)
|
||||
cseOptimize :: PGF -> PGF
|
||||
cseOptimize pgf = pgf {
|
||||
concretes = Map.map subex (concretes pgf)
|
||||
}
|
||||
|
||||
-- analyse word form lists into prefix + suffixes
|
||||
|
||||
@@ -73,7 +73,7 @@ data Phase = Preproc | Convert | Compile | Link
|
||||
data Encoding = UTF_8 | ISO_8859_1
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data OutputFormat = FmtGFCC | FmtJavaScript | FmtHaskell | FmtHaskellGADT
|
||||
data OutputFormat = FmtPGF | FmtJavaScript | FmtHaskell | FmtHaskellGADT
|
||||
deriving (Eq,Ord)
|
||||
|
||||
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
|
||||
@@ -252,7 +252,7 @@ defaultFlags = Flags {
|
||||
optShowCPUTime = False,
|
||||
optEmitGFO = True,
|
||||
optGFODir = ".",
|
||||
optOutputFormats = [FmtGFCC],
|
||||
optOutputFormats = [FmtPGF],
|
||||
optOutputFile = Nothing,
|
||||
optOutputDir = Nothing,
|
||||
optRecomp = RecompIfNewer,
|
||||
@@ -344,7 +344,7 @@ optDescr =
|
||||
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
|
||||
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
|
||||
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 [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (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 ['f'] ["output-format"] (ReqArg outFmt "FMT")
|
||||
(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, ...",
|
||||
"Abstract only: haskell, ..."]),
|
||||
Option ['o'] ["output-file"] (ReqArg outFile "FILE")
|
||||
@@ -392,7 +392,7 @@ optDescr =
|
||||
|
||||
outputFormats :: [(String,OutputFormat)]
|
||||
outputFormats =
|
||||
[("gfcc", FmtGFCC),
|
||||
[("pgf", FmtPGF),
|
||||
("js", FmtJavaScript),
|
||||
("haskell", FmtHaskell),
|
||||
("haskell_gadt", FmtHaskellGADT)]
|
||||
|
||||
@@ -22,16 +22,16 @@ mainGFC opts fs =
|
||||
let cnc = justModuleName (last fs)
|
||||
if flag optStopAfterPhase opts == Compile
|
||||
then return ()
|
||||
else do gfcc <- link opts cnc gr
|
||||
writeOutputs opts gfcc
|
||||
else do pgf <- link opts cnc gr
|
||||
writeOutputs opts pgf
|
||||
|
||||
writeOutputs :: Options -> GFCC -> IOE ()
|
||||
writeOutputs opts gfcc = mapM_ (\fmt -> writeOutput opts fmt gfcc) (flag optOutputFormats opts)
|
||||
writeOutputs :: Options -> PGF -> IOE ()
|
||||
writeOutputs opts pgf = mapM_ (\fmt -> writeOutput opts fmt pgf) (flag optOutputFormats opts)
|
||||
|
||||
writeOutput :: Options -> OutputFormat-> GFCC -> IOE ()
|
||||
writeOutput opts fmt gfcc =
|
||||
do let path = outputFilePath opts fmt (prCId (absname gfcc))
|
||||
s = prGFCC fmt gfcc
|
||||
writeOutput :: Options -> OutputFormat-> PGF -> IOE ()
|
||||
writeOutput opts fmt pgf =
|
||||
do let path = outputFilePath opts fmt (prCId (absname pgf))
|
||||
s = prPGF fmt pgf
|
||||
writeOutputFile path s
|
||||
|
||||
outputFilePath :: Options -> OutputFormat -> String -> FilePath
|
||||
@@ -40,7 +40,7 @@ outputFilePath opts fmt name0 = addDir name <.> fmtExtension fmt
|
||||
addDir = maybe id (</>) (flag optOutputDir opts)
|
||||
|
||||
fmtExtension :: OutputFormat -> String
|
||||
fmtExtension FmtGFCC = "gfcc"
|
||||
fmtExtension FmtPGF = "pgf"
|
||||
fmtExtension FmtJavaScript = "js"
|
||||
fmtExtension FmtHaskell = "hs"
|
||||
fmtExtension FmtHaskellGADT = "hs"
|
||||
|
||||
@@ -19,7 +19,7 @@ import Paths_gf
|
||||
mainGFI :: Options -> [FilePath] -> IO ()
|
||||
mainGFI opts files = do
|
||||
putStrLn welcome
|
||||
env <- importInEnv emptyMultiGrammar opts files
|
||||
env <- importInEnv emptyPGF opts files
|
||||
loop (GFEnv emptyGrammar env [] 0)
|
||||
return ()
|
||||
|
||||
@@ -50,7 +50,7 @@ loop gfenv0 = do
|
||||
loopNewCPU 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
|
||||
"q":_ -> putStrLn "See you." >> return gfenv
|
||||
|
||||
@@ -64,13 +64,13 @@ loopNewCPU gfenv = do
|
||||
putStrLn (show ((cpu' - cputime gfenv) `div` 1000000000) ++ " msec")
|
||||
loop $ gfenv {cputime = cpu'}
|
||||
|
||||
importInEnv :: MultiGrammar -> Options -> [FilePath] -> IO CommandEnv
|
||||
importInEnv mgr0 opts files = do
|
||||
mgr1 <- case files of
|
||||
[] -> return mgr0
|
||||
_ -> importGrammar mgr0 opts files
|
||||
let env = CommandEnv mgr1 (allCommands mgr1)
|
||||
putStrLn $ unwords $ "\nLanguages:" : languages mgr1
|
||||
importInEnv :: PGF -> Options -> [FilePath] -> IO CommandEnv
|
||||
importInEnv pgf0 opts files = do
|
||||
pgf1 <- case files of
|
||||
[] -> return pgf0
|
||||
_ -> importGrammar pgf0 opts files
|
||||
let env = CommandEnv pgf1 (allCommands pgf1)
|
||||
putStrLn $ unwords $ "\nLanguages:" : languages pgf1
|
||||
return env
|
||||
|
||||
welcome = unlines [
|
||||
|
||||
@@ -13,7 +13,7 @@
|
||||
-- embedded GF systems. AR 19/9/2007
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module PGF where
|
||||
module PGF(module PGF, PGF, emptyPGF) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Linearize
|
||||
@@ -43,51 +43,46 @@ import qualified Text.ParserCombinators.ReadP as RP
|
||||
-- Interface
|
||||
---------------------------------------------------
|
||||
|
||||
data MultiGrammar = MultiGrammar {gfcc :: GFCC}
|
||||
type Language = String
|
||||
type Category = String
|
||||
type Tree = Exp
|
||||
|
||||
file2grammar :: FilePath -> IO MultiGrammar
|
||||
file2pgf :: FilePath -> IO PGF
|
||||
|
||||
linearize :: MultiGrammar -> Language -> Tree -> String
|
||||
parse :: MultiGrammar -> Language -> Category -> String -> [Tree]
|
||||
linearize :: PGF -> Language -> Tree -> String
|
||||
parse :: PGF -> Language -> Category -> String -> [Tree]
|
||||
|
||||
linearizeAll :: MultiGrammar -> Tree -> [String]
|
||||
linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)]
|
||||
linearizeAll :: PGF -> Tree -> [String]
|
||||
linearizeAllLang :: PGF -> Tree -> [(Language,String)]
|
||||
|
||||
parseAll :: MultiGrammar -> Category -> String -> [[Tree]]
|
||||
parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])]
|
||||
parseAll :: PGF -> Category -> String -> [[Tree]]
|
||||
parseAllLang :: PGF -> Category -> String -> [(Language,[Tree])]
|
||||
|
||||
generateAll :: MultiGrammar -> Category -> [Tree]
|
||||
generateRandom :: MultiGrammar -> Category -> IO [Tree]
|
||||
generateAllDepth :: MultiGrammar -> Category -> Maybe Int -> [Tree]
|
||||
generateAll :: PGF -> Category -> [Tree]
|
||||
generateRandom :: PGF -> Category -> IO [Tree]
|
||||
generateAllDepth :: PGF -> Category -> Maybe Int -> [Tree]
|
||||
|
||||
readTree :: String -> Tree
|
||||
showTree :: Tree -> String
|
||||
|
||||
languages :: MultiGrammar -> [Language]
|
||||
categories :: MultiGrammar -> [Category]
|
||||
languages :: PGF -> [Language]
|
||||
categories :: PGF -> [Category]
|
||||
|
||||
startCat :: MultiGrammar -> Category
|
||||
startCat :: PGF -> Category
|
||||
|
||||
---------------------------------------------------
|
||||
-- Implementation
|
||||
---------------------------------------------------
|
||||
|
||||
file2grammar f = do
|
||||
gfcc <- file2gfcc f
|
||||
return (MultiGrammar gfcc)
|
||||
|
||||
file2gfcc f = do
|
||||
file2pgf f = do
|
||||
s <- readFileIf f
|
||||
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 =
|
||||
case lookParser (gfcc mgr) (mkCId lang) of
|
||||
parse pgf lang cat s =
|
||||
case lookParser pgf (mkCId lang) of
|
||||
Nothing -> error "no parser"
|
||||
Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
|
||||
Ok x -> x
|
||||
@@ -102,12 +97,12 @@ parseAll mgr cat = map snd . parseAllLang mgr cat
|
||||
parseAllLang mgr cat s =
|
||||
[(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
|
||||
return $ genRandom gen (gfcc mgr) (mkCId cat)
|
||||
return $ genRandom gen pgf (mkCId cat)
|
||||
|
||||
generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing
|
||||
generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat)
|
||||
generateAll pgf cat = generate pgf (mkCId cat) Nothing
|
||||
generateAllDepth pgf cat = generate pgf (mkCId cat)
|
||||
|
||||
readTree s = case RP.readP_to_S (pExp False) s of
|
||||
[(x,"")] -> x
|
||||
@@ -158,15 +153,14 @@ ppExp isNested (EVar id) = PP.text (prCId id)
|
||||
ppParens True = PP.parens
|
||||
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
|
||||
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module PGF.Check (checkGFCC, checkGFCCio, checkGFCCmaybe) where
|
||||
module PGF.Check (checkPGF) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
@@ -9,26 +9,11 @@ import qualified Data.Map as Map
|
||||
import Control.Monad
|
||||
import Debug.Trace
|
||||
|
||||
checkGFCCio :: GFCC -> IO GFCC
|
||||
checkGFCCio gfcc = case checkGFCC gfcc of
|
||||
Ok (gc,b) -> do
|
||||
putStrLn $ if b then "OK" else "Corrupted GFCC"
|
||||
return gc
|
||||
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)
|
||||
checkPGF :: PGF -> Err (PGF,Bool)
|
||||
checkPGF pgf = do
|
||||
(cs,bs) <- mapM (checkConcrete pgf)
|
||||
(Map.assocs (concretes pgf)) >>= return . unzip
|
||||
return (pgf {concretes = Map.fromAscList cs}, and bs)
|
||||
|
||||
|
||||
-- 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))
|
||||
|
||||
|
||||
checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool)
|
||||
checkConcrete gfcc (lang,cnc) =
|
||||
checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool)
|
||||
checkConcrete pgf (lang,cnc) =
|
||||
labelBoolErr ("happened in language " ++ prCId lang) $ do
|
||||
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
|
||||
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
|
||||
where
|
||||
checkl = checkLin gfcc lang
|
||||
checkl = checkLin pgf lang
|
||||
|
||||
checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
|
||||
checkLin gfcc lang (f,t) =
|
||||
checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
|
||||
checkLin pgf lang (f,t) =
|
||||
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)
|
||||
|
||||
inferTerm :: [CType] -> Term -> Err (Term,CType)
|
||||
@@ -137,22 +122,22 @@ ints = C
|
||||
str :: CType
|
||||
str = S []
|
||||
|
||||
lintype :: GFCC -> CId -> CId -> LinType
|
||||
lintype gfcc lang fun = case typeSkeleton (lookType gfcc fun) of
|
||||
lintype :: PGF -> CId -> CId -> LinType
|
||||
lintype pgf lang fun = case typeSkeleton (lookType pgf fun) of
|
||||
(cs,c) -> (map vlinc cs, linc c) ---- HOAS
|
||||
where
|
||||
linc = lookLincat gfcc lang
|
||||
linc = lookLincat pgf lang
|
||||
vlinc (0,c) = linc c
|
||||
vlinc (i,c) = case linc c of
|
||||
R ts -> R (ts ++ replicate i str)
|
||||
|
||||
inline :: GFCC -> CId -> Term -> Term
|
||||
inline gfcc lang t = case t of
|
||||
inline :: PGF -> CId -> Term -> Term
|
||||
inline pgf lang t = case t of
|
||||
F c -> inl $ look c
|
||||
_ -> composSafeOp inl t
|
||||
where
|
||||
inl = inline gfcc lang
|
||||
look = lookLin gfcc lang
|
||||
inl = inline pgf lang
|
||||
look = lookLin pgf lang
|
||||
|
||||
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
|
||||
composOp f trm = case trm of
|
||||
|
||||
@@ -8,9 +8,9 @@ import qualified Data.Map as Map
|
||||
import Data.List
|
||||
import Data.Array
|
||||
|
||||
-- internal datatypes for GFCC
|
||||
-- internal datatypes for PGF
|
||||
|
||||
data GFCC = GFCC {
|
||||
data PGF = PGF {
|
||||
absname :: CId ,
|
||||
cncnames :: [CId] ,
|
||||
gflags :: Map.Map CId String, -- value of a global flag
|
||||
@@ -120,17 +120,17 @@ fcatVar = (-4)
|
||||
|
||||
-- print statistics
|
||||
|
||||
statGFCC :: GFCC -> String
|
||||
statGFCC gfcc = unlines [
|
||||
"Abstract\t" ++ prCId (absname gfcc),
|
||||
"Concretes\t" ++ unwords (map prCId (cncnames gfcc)),
|
||||
"Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract gfcc))))
|
||||
statGFCC :: PGF -> String
|
||||
statGFCC pgf = unlines [
|
||||
"Abstract\t" ++ prCId (absname pgf),
|
||||
"Concretes\t" ++ unwords (map prCId (cncnames pgf)),
|
||||
"Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract pgf))))
|
||||
]
|
||||
|
||||
-- merge two GFCCs; fails is differens absnames; priority to second arg
|
||||
|
||||
unionGFCC :: GFCC -> GFCC -> GFCC
|
||||
unionGFCC one two = case absname one of
|
||||
unionPGF :: PGF -> PGF -> PGF
|
||||
unionPGF one two = case absname one of
|
||||
n | n == wildCId -> two -- extending empty grammar
|
||||
| n == absname two -> one { -- extending grammar with same abstract
|
||||
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
|
||||
|
||||
emptyGFCC :: GFCC
|
||||
emptyGFCC = GFCC {
|
||||
emptyPGF :: PGF
|
||||
emptyPGF = PGF {
|
||||
absname = wildCId,
|
||||
cncnames = [] ,
|
||||
gflags = Map.empty,
|
||||
@@ -149,9 +149,9 @@ emptyGFCC = GFCC {
|
||||
|
||||
-- encode idenfifiers and strings in UTF8
|
||||
|
||||
utf8GFCC :: GFCC -> GFCC
|
||||
utf8GFCC gfcc = gfcc {
|
||||
concretes = Map.map u8concr (concretes gfcc)
|
||||
utf8GFCC :: PGF -> PGF
|
||||
utf8GFCC pgf = pgf {
|
||||
concretes = Map.map u8concr (concretes pgf)
|
||||
}
|
||||
where
|
||||
u8concr cnc = cnc {
|
||||
|
||||
@@ -8,8 +8,8 @@ import qualified Data.Map as M
|
||||
import System.Random
|
||||
|
||||
-- generate an infinite list of trees exhaustively
|
||||
generate :: GFCC -> CId -> Maybe Int -> [Exp]
|
||||
generate gfcc cat dp = concatMap (\i -> gener i cat) depths
|
||||
generate :: PGF -> CId -> Maybe Int -> [Exp]
|
||||
generate pgf cat dp = concatMap (\i -> gener i cat) depths
|
||||
where
|
||||
gener 0 c = [EApp f [] | (f, ([],_)) <- fns c]
|
||||
gener i c = [
|
||||
@@ -20,12 +20,12 @@ generate gfcc cat dp = concatMap (\i -> gener i cat) depths
|
||||
let tr = EApp f ts,
|
||||
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
|
||||
|
||||
-- generate an infinite list of trees randomly
|
||||
genRandom :: StdGen -> GFCC -> CId -> [Exp]
|
||||
genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
|
||||
genRandom :: StdGen -> PGF -> CId -> [Exp]
|
||||
genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
|
||||
|
||||
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)
|
||||
_ -> ([],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
|
||||
-- because it is not known which field in each rule may match the input
|
||||
|
||||
searchParse :: Int -> GFCC -> CId -> [String] -> [Exp]
|
||||
searchParse i gfcc cat ws = [t | t <- gen, s <- lins t, words s == ws] where
|
||||
gen = take i $ generate gfcc cat
|
||||
lins t = [linearize gfcc lang t | lang <- cncnames gfcc]
|
||||
searchParse :: Int -> PGF -> CId -> [String] -> [Exp]
|
||||
searchParse i pgf cat ws = [t | t <- gen, s <- lins t, words s == ws] where
|
||||
gen = take i $ generate pgf cat
|
||||
lins t = [linearize pgf lang t | lang <- cncnames pgf]
|
||||
-}
|
||||
|
||||
@@ -8,10 +8,10 @@ import Data.List
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
-- linearization and computation of concrete GFCC Terms
|
||||
-- linearization and computation of concrete PGF Terms
|
||||
|
||||
linearize :: GFCC -> CId -> Exp -> String
|
||||
linearize mcfg lang = realize . linExp mcfg lang
|
||||
linearize :: PGF -> CId -> Exp -> String
|
||||
linearize pgf lang = realize . linExp pgf lang
|
||||
|
||||
realize :: Term -> String
|
||||
realize trm = case trm of
|
||||
@@ -25,8 +25,8 @@ realize trm = case trm of
|
||||
TM s -> s
|
||||
_ -> "ERROR " ++ show trm ---- debug
|
||||
|
||||
linExp :: GFCC -> CId -> Exp -> Term
|
||||
linExp gfcc lang = lin
|
||||
linExp :: PGF -> CId -> Exp -> Term
|
||||
linExp pgf lang = lin
|
||||
where
|
||||
lin (EAbs xs e ) = case lin e of
|
||||
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 (EMeta i ) = TM (show i)
|
||||
|
||||
comp = compute gfcc lang
|
||||
look = lookLin gfcc lang
|
||||
comp = compute pgf lang
|
||||
look = lookLin pgf lang
|
||||
|
||||
|
||||
compute :: GFCC -> CId -> [Term] -> Term -> Term
|
||||
compute mcfg lang args = comp where
|
||||
compute :: PGF -> CId -> [Term] -> Term -> Term
|
||||
compute pgf lang args = comp where
|
||||
comp trm = case trm of
|
||||
P r p -> proj (comp r) (comp p)
|
||||
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
|
||||
_ -> trm
|
||||
|
||||
look = lookOper mcfg lang
|
||||
look = lookOper pgf lang
|
||||
|
||||
idx xs i = if i > length xs - 1
|
||||
then trace
|
||||
|
||||
@@ -8,58 +8,58 @@ import qualified Data.Array as Array
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
|
||||
-- operations for manipulating GFCC grammars and objects
|
||||
-- operations for manipulating PGF grammars and objects
|
||||
|
||||
lookLin :: GFCC -> CId -> CId -> Term
|
||||
lookLin gfcc lang fun =
|
||||
lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc
|
||||
lookLin :: PGF -> CId -> CId -> Term
|
||||
lookLin pgf lang fun =
|
||||
lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
lookOper :: GFCC -> CId -> CId -> Term
|
||||
lookOper gfcc lang fun =
|
||||
lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc
|
||||
lookOper :: PGF -> CId -> CId -> Term
|
||||
lookOper pgf lang fun =
|
||||
lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
lookLincat :: GFCC -> CId -> CId -> Term
|
||||
lookLincat gfcc lang fun =
|
||||
lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc
|
||||
lookLincat :: PGF -> CId -> CId -> Term
|
||||
lookLincat pgf lang fun =
|
||||
lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
lookParamLincat :: GFCC -> CId -> CId -> Term
|
||||
lookParamLincat gfcc lang fun =
|
||||
lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc
|
||||
lookParamLincat :: PGF -> CId -> CId -> Term
|
||||
lookParamLincat pgf lang fun =
|
||||
lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
lookType :: GFCC -> CId -> Type
|
||||
lookType gfcc f =
|
||||
fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc))
|
||||
lookType :: PGF -> CId -> Type
|
||||
lookType pgf f =
|
||||
fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf))
|
||||
|
||||
lookParser :: GFCC -> CId -> Maybe ParserInfo
|
||||
lookParser gfcc lang = parser $ lookMap (error "no lang") lang $ concretes gfcc
|
||||
lookParser :: PGF -> CId -> Maybe ParserInfo
|
||||
lookParser pgf lang = parser $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
lookFCFG :: GFCC -> CId -> Maybe FGrammar
|
||||
lookFCFG gfcc lang = fmap toFGrammar $ lookParser gfcc lang
|
||||
lookFCFG :: PGF -> CId -> Maybe FGrammar
|
||||
lookFCFG pgf lang = fmap toFGrammar $ lookParser pgf lang
|
||||
where
|
||||
toFGrammar :: ParserInfo -> FGrammar
|
||||
toFGrammar pinfo = (Array.elems (allRules pinfo), startupCats pinfo)
|
||||
|
||||
lookStartCat :: GFCC -> String
|
||||
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
|
||||
[gflags gfcc, aflags (abstract gfcc)]
|
||||
lookStartCat :: PGF -> String
|
||||
lookStartCat pgf = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat"))
|
||||
[gflags pgf, aflags (abstract pgf)]
|
||||
|
||||
lookGlobalFlag :: GFCC -> CId -> String
|
||||
lookGlobalFlag gfcc f =
|
||||
lookMap "?" f (gflags gfcc)
|
||||
lookGlobalFlag :: PGF -> CId -> String
|
||||
lookGlobalFlag pgf f =
|
||||
lookMap "?" f (gflags pgf)
|
||||
|
||||
lookAbsFlag :: GFCC -> CId -> String
|
||||
lookAbsFlag gfcc f =
|
||||
lookMap "?" f (aflags (abstract gfcc))
|
||||
lookAbsFlag :: PGF -> CId -> String
|
||||
lookAbsFlag pgf f =
|
||||
lookMap "?" f (aflags (abstract pgf))
|
||||
|
||||
lookCncFlag :: GFCC -> CId -> CId -> String
|
||||
lookCncFlag gfcc lang f =
|
||||
lookMap "?" f $ cflags $ lookMap (error "no lang") lang $ concretes gfcc
|
||||
lookCncFlag :: PGF -> CId -> CId -> String
|
||||
lookCncFlag pgf lang f =
|
||||
lookMap "?" f $ cflags $ lookMap (error "no lang") lang $ concretes pgf
|
||||
|
||||
functionsToCat :: GFCC -> CId -> [(CId,Type)]
|
||||
functionsToCat gfcc cat =
|
||||
[(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract gfcc]]
|
||||
functionsToCat :: PGF -> CId -> [(CId,Type)]
|
||||
functionsToCat pgf cat =
|
||||
[(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract pgf]]
|
||||
where
|
||||
fs = lookMap [] cat $ catfuns $ abstract gfcc
|
||||
fs = lookMap [] cat $ catfuns $ abstract pgf
|
||||
|
||||
depth :: Exp -> Int
|
||||
depth (EAbs _ t) = depth t
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module PGF.Raw.Convert (toGFCC,fromGFCC) where
|
||||
module PGF.Raw.Convert (toPGF,fromPGF) where
|
||||
|
||||
import PGF.CId
|
||||
import PGF.Data
|
||||
@@ -12,10 +12,10 @@ import qualified Data.Map as Map
|
||||
pgfMajorVersion, pgfMinorVersion :: Integer
|
||||
(pgfMajorVersion, pgfMinorVersion) = (1,0)
|
||||
|
||||
-- convert parsed grammar to internal GFCC
|
||||
-- convert parsed grammar to internal PGF
|
||||
|
||||
toGFCC :: Grammar -> GFCC
|
||||
toGFCC (Grm [
|
||||
toPGF :: Grammar -> PGF
|
||||
toPGF (Grm [
|
||||
App "pgf" (AInt v1 : AInt v2 : App a []:cs),
|
||||
App "flags" gfs,
|
||||
ab@(
|
||||
@@ -24,7 +24,7 @@ toGFCC (Grm [
|
||||
App "cat" cts
|
||||
]),
|
||||
App "concrete" ccs
|
||||
]) = GFCC {
|
||||
]) = PGF {
|
||||
absname = mkCId a,
|
||||
cncnames = [mkCId c | App c [] <- cs],
|
||||
gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
|
||||
@@ -135,20 +135,20 @@ toTerm e = case e of
|
||||
--- from internal to parser --
|
||||
------------------------------
|
||||
|
||||
fromGFCC :: GFCC -> Grammar
|
||||
fromGFCC gfcc0 = Grm [
|
||||
fromPGF :: PGF -> Grammar
|
||||
fromPGF pgf0 = Grm [
|
||||
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
|
||||
: App (prCId (absname gfcc)) [] : map (flip App [] . prCId) (cncnames gfcc)),
|
||||
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags gfcc `Map.union` aflags agfcc)],
|
||||
: App (prCId (absname pgf)) [] : map (flip App [] . prCId) (cncnames pgf)),
|
||||
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags pgf `Map.union` aflags apgf)],
|
||||
App "abstract" [
|
||||
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs agfcc)],
|
||||
App "cat" [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats 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 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
|
||||
gfcc = utf8GFCC gfcc0
|
||||
agfcc = abstract gfcc
|
||||
pgf = utf8GFCC pgf0
|
||||
apgf = abstract pgf
|
||||
fromConcrete 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)],
|
||||
|
||||
@@ -37,7 +37,7 @@ prRecord = prr where
|
||||
RS s -> prQuotedString 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 typ trm = case (typ,trm) of
|
||||
(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
|
||||
|
||||
-- show all branches, without labels and params
|
||||
allLinearize :: GFCC -> CId -> Exp -> String
|
||||
allLinearize gfcc lang = concat . map pr . tabularLinearize gfcc lang where
|
||||
allLinearize :: PGF -> CId -> Exp -> String
|
||||
allLinearize pgf lang = concat . map pr . tabularLinearize pgf lang where
|
||||
pr (p,vs) = unlines vs
|
||||
|
||||
-- show all branches, with labels and params
|
||||
tableLinearize :: GFCC -> CId -> Exp -> String
|
||||
tableLinearize gfcc lang = unlines . map pr . tabularLinearize gfcc lang where
|
||||
tableLinearize :: PGF -> CId -> Exp -> String
|
||||
tableLinearize pgf lang = unlines . map pr . tabularLinearize pgf lang where
|
||||
pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs)
|
||||
|
||||
-- create a table from labels+params to variants
|
||||
tabularLinearize :: GFCC -> CId -> Exp -> [(String,[String])]
|
||||
tabularLinearize gfcc lang = branches . recLinearize gfcc lang where
|
||||
tabularLinearize :: PGF -> CId -> Exp -> [(String,[String])]
|
||||
tabularLinearize pgf lang = branches . recLinearize pgf lang where
|
||||
branches r = case r of
|
||||
RR 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 _ -> []
|
||||
|
||||
-- show record in GF-source-like syntax
|
||||
recordLinearize :: GFCC -> CId -> Exp -> String
|
||||
recordLinearize gfcc lang = prRecord . recLinearize gfcc lang
|
||||
recordLinearize :: PGF -> CId -> Exp -> String
|
||||
recordLinearize pgf lang = prRecord . recLinearize pgf lang
|
||||
|
||||
-- create a GF-like record, forming the basis of all functions above
|
||||
recLinearize :: GFCC -> CId -> Exp -> Record
|
||||
recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where
|
||||
recLinearize :: PGF -> CId -> Exp -> Record
|
||||
recLinearize pgf lang exp = mkRecord typ $ linExp pgf lang exp where
|
||||
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
|
||||
termLinearize :: GFCC -> CId -> Exp -> String
|
||||
termLinearize gfcc lang = show . linExp gfcc lang
|
||||
-- show PGF term
|
||||
termLinearize :: PGF -> CId -> Exp -> String
|
||||
termLinearize pgf lang = show . linExp pgf lang
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user