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

cleanup

Browse Source
This commit is contained in:
krangelov
2019-09-19 22:30:08 +02:00
parent 4a71464ca7
commit acb70ccc1b
50 changed files with 537 additions and 1964 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
src/compiler/GF/Command/Abstract.hs
View File

@@ -1,6 +1,6 @@
module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where
import PGF(CId,mkCId,Expr,showExpr)
import PGF2(Expr,showExpr)
import GF.Grammar.Grammar(Term)
type Ident = String
@@ -31,12 +31,6 @@ data Argument
| AMacro Ident
deriving Show
valCIdOpts :: String -> CId -> [Option] -> CId
valCIdOpts flag def opts =
case [v | OFlag f (VId v) <- opts, f == flag] of
(v:_) -> mkCId v
_ -> def
valIntOpts :: String -> Int -> [Option] -> Int
valIntOpts flag def opts =
case [v | OFlag f (VInt v) <- opts, f == flag] of
@@ -49,12 +43,6 @@ valStrOpts flag def opts =
v:_ -> valueString v
_ -> def
maybeCIdOpts :: String -> a -> (CId -> a) -> [Option] -> a
maybeCIdOpts flag def fn opts =
case [v | OFlag f (VId v) <- opts, f == flag] of
(v:_) -> fn (mkCId v)
_ -> def
maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
maybeIntOpts flag def fn opts =
case [v | OFlag f (VInt v) <- opts, f == flag] of

2
src/compiler/GF/Command/CommandInfo.hs
View File

@@ -3,7 +3,7 @@ import GF.Command.Abstract(Option,Expr,Term)
import GF.Text.Pretty(render)
import GF.Grammar.Printer() -- instance Pretty Term
import GF.Grammar.Macros(string2term)
import PGF(mkStr,unStr,showExpr)
import PGF2(mkStr,unStr,showExpr)
data CommandInfo m = CommandInfo {
exec :: [Option] -> CommandArguments -> m CommandOutput,

405
src/compiler/GF/Command/Commands.hs
View File

@@ -1,12 +1,12 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands (
PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
HasPGF(..),pgfCommands,
options,flags,
) where
import Prelude hiding (putStrLn)
import PGF
import PGF.Internal(writePGF)
import PGF2
import PGF2.Internal(writePGF)
import GF.Compile.Export
import GF.Compile.ToAPI
@@ -24,33 +24,25 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
import GF.Data.Operations
-- import PGF.Internal (encodeFile)
import Data.Char
import Data.List(intersperse,nub)
import Data.Maybe
import qualified Data.Map as Map
import GF.Text.Pretty
import Data.List (sort)
--import Debug.Trace
import Control.Monad(mplus)
class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
data PGFEnv = Env {pgf::Maybe PGF,mos::Map.Map Language Morpho}
instance (Monad m,HasPGF m) => TypeCheckArg m where
typeCheckArg e = do mb_pgf <- getPGF
case mb_pgf of
Just pgf -> either fail
(return . fst)
(inferExpr pgf e)
Nothing -> fail "Import a grammar before using this command"
pgfEnv mb_pgf = Env mb_pgf mos
where mos = case mb_pgf of
Just pgf -> Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
Nothing -> Map.empty
class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
instance (Monad m,HasPGFEnv m) => TypeCheckArg m where
typeCheckArg e = do env <- getPGFEnv
case pgf env of
Just gr -> either (fail . render . ppTcError)
(return . fst)
(inferExpr gr e)
Nothing -> fail "Import a grammar before using this command"
pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
pgfCommands :: HasPGF m => Map.Map String (CommandInfo m)
pgfCommands = Map.fromList [
("aw", emptyCommandInfo {
longname = "align_words",
@@ -63,7 +55,7 @@ pgfCommands = Map.fromList [
"by the view flag. The target format is png, unless overridden by the",
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
],
exec = needPGF $ \ opts arg pgf mos -> do
exec = needPGF $ \ opts arg pgf -> do
let es = toExprs arg
let langs = optLangs pgf opts
if isOpt "giza" opts
@@ -75,7 +67,7 @@ pgfCommands = Map.fromList [
let grph = if null es then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
return $ fromString grph
else do
let grphs = map (graphvizAlignment pgf langs) es
let grphs = map (graphvizWordAlignment langs graphvizDefaults) es
if isFlag "view" opts || isFlag "format" opts
then do
let view = optViewGraph opts
@@ -108,16 +100,17 @@ pgfCommands = Map.fromList [
"by the flag '-clitics'. The list of stems is given as the list of words",
"of the language given by the '-lang' flag."
],
exec = needPGF $ \opts ts pgf mos -> case opts of
_ | isOpt "raw" opts ->
return . fromString .
unlines . map (unwords . map (concat . intersperse "+")) .
map (getClitics (isInMorpho (optMorpho pgf mos opts)) (optClitics opts)) .
concatMap words $ toStrings ts
_ ->
return . fromStrings .
getCliticsText (isInMorpho (optMorpho pgf mos opts)) (optClitics opts) .
concatMap words $ toStrings ts,
exec = needPGF $ \opts ts pgf -> do
concr <- optLang pgf opts
case opts of
_ | isOpt "raw" opts ->
return . fromString .
unlines . map (unwords . map (concat . intersperse "+")) .
map (getClitics (not . null . lookupMorpho concr) (optClitics opts)) .
concatMap words $ toStrings ts
_ -> return . fromStrings .
getCliticsText (not . null . lookupMorpho concr) (optClitics opts) .
concatMap words $ toStrings ts,
flags = [
("clitics","the list of possible clitics (comma-separated, no spaces)"),
("lang", "the language of analysis")
@@ -151,10 +144,11 @@ pgfCommands = Map.fromList [
("file","the file to be converted (suffix .gfe must be given)"),
("lang","the language in which to parse")
],
exec = needPGF $ \ opts _ pgf mos -> do
exec = needPGF $ \opts _ pgf -> do
let file = optFile opts
let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
let conf = configureExBased pgf (optMorpho pgf mos opts) (optLang pgf opts) printer
concr <- optLang pgf opts
let conf = configureExBased pgf concr printer
(file',ws) <- restricted $ parseExamplesInGrammar conf file
if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
return (fromString ("wrote " ++ file')),
@@ -175,21 +169,19 @@ pgfCommands = Map.fromList [
explanation = unlines [
"Generates a list of random trees, by default one tree.",
"If a tree argument is given, the command completes the Tree with values to",
"all metavariables in the tree. The generation can be biased by probabilities,",
"given in a file in the -probs flag."
"all metavariables in the tree. The generation can be biased by probabilities",
"if the grammar was compiled with option -probs"
],
flags = [
("cat","generation category"),
("lang","uses only functions that have linearizations in all these languages"),
("number","number of trees generated"),
("depth","the maximum generation depth")
("number","number of trees generated")
],
exec = needPGF $ \ opts arg pgf mos -> do
exec = needPGF $ \opts arg pgf -> do
gen <- newStdGen
let dp = valIntOpts "depth" 4 opts
let ts = case mexp (toExprs arg) of
Just ex -> generateRandomFromDepth gen pgf ex (Just dp)
Nothing -> generateRandomDepth gen pgf (optType pgf opts) (Just dp)
Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom gen pgf (optType pgf opts)
returnFromExprs $ take (optNum opts) ts
}),
@@ -197,29 +189,25 @@ pgfCommands = Map.fromList [
longname = "generate_trees",
synopsis = "generates a list of trees, by default exhaustive",
explanation = unlines [
"Generates all trees of a given category. By default, ",
"the depth is limited to 4, but this can be changed by a flag.",
"Generates all trees of a given category.",
"If a Tree argument is given, the command completes the Tree with values",
"to all metavariables in the tree."
],
flags = [
("cat","the generation category"),
("depth","the maximum generation depth"),
("lang","excludes functions that have no linearization in this language"),
("number","the number of trees generated")
],
examples = [
mkEx "gt -- all trees in the startcat, to depth 4",
mkEx "gt -- all trees in the startcat",
mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP",
mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2",
mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))"
],
exec = needPGF $ \opts arg pgf mos -> do
let dp = valIntOpts "depth" 4 opts
exec = needPGF $ \opts arg pgf -> do
let ts = case mexp (toExprs arg) of
Just ex -> generateFromDepth pgf ex (Just dp)
Nothing -> generateAllDepth pgf (optType pgf opts) (Just dp)
returnFromExprs $ take (optNumInf opts) ts
Just ex -> generateAllFrom pgf ex
Nothing -> generateAll pgf (optType pgf opts)
returnFromExprs $ take (optNumInf opts) (map fst ts)
}),
("i", emptyCommandInfo {
@@ -253,22 +241,17 @@ pgfCommands = Map.fromList [
longname = "linearize",
synopsis = "convert an abstract syntax expression to string",
explanation = unlines [
"Shows the linearization of a Tree by the grammars in scope.",
"Shows the linearization of a tree by the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"A sequence of string operations (see command ps) can be given",
"as options, and works then like a pipe to the ps command, except",
"that it only affect the strings, not e.g. the table labels.",
"These can be given separately to each language with the unlexer flag",
"whose results are prepended to the other lexer flags. The value of the",
"unlexer flag is a space-separated list of comma-separated string operation",
"sequences; see example."
"that it only affect the strings, not e.g. the table labels."
],
examples = [
mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor",
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table"
],
exec = needPGF $ \ opts ts pgf mos -> return . fromStrings . optLins pgf opts $ toExprs ts,
exec = needPGF $ \ opts ts pgf -> return . fromStrings . optLins pgf opts $ toExprs ts,
options = [
("all", "show all forms and variants, one by line (cf. l -list)"),
("bracket","show tree structure with brackets and paths to nodes"),
@@ -279,8 +262,7 @@ pgfCommands = Map.fromList [
("treebank","show the tree and tag linearizations with language names")
] ++ stringOpOptions,
flags = [
("lang","the languages of linearization (comma-separated, no spaces)"),
("unlexer","set unlexers separately to each language (space-separated)")
("lang","the languages of linearization (comma-separated, no spaces)")
]
}),
@@ -291,18 +273,20 @@ pgfCommands = Map.fromList [
"Prints all the analyses of space-separated words in the input string,",
"using the morphological analyser of the actual grammar (see command pg)"
],
exec = needPGF $ \opts ts pgf mos -> case opts of
_ | isOpt "missing" opts ->
return . fromString . unwords .
morphoMissing (optMorpho pgf mos opts) .
concatMap words $ toStrings ts
_ | isOpt "known" opts ->
return . fromString . unwords .
morphoKnown (optMorpho pgf mos opts) .
concatMap words $ toStrings ts
_ -> return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos pgf mos opts) .
concatMap words $ toStrings ts,
exec = needPGF $ \opts ts pgf -> do
concr <- optLang pgf opts
case opts of
_ | isOpt "missing" opts ->
return . fromString . unwords .
morphoMissing concr .
concatMap words $ toStrings ts
_ | isOpt "known" opts ->
return . fromString . unwords .
morphoKnown concr .
concatMap words $ toStrings ts
_ -> return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos pgf opts) .
concatMap words $ toStrings ts,
flags = [
("lang","the languages of analysis (comma-separated, no spaces)")
],
@@ -316,8 +300,8 @@ pgfCommands = Map.fromList [
longname = "morpho_quiz",
synopsis = "start a morphology quiz",
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
exec = needPGF $ \ opts arg pgf mos -> do
let lang = optLang pgf opts
exec = needPGF $ \ opts arg pgf -> do
lang <- optLang pgf opts
let typ = optType pgf opts
let mt = mexp (toExprs arg)
restricted $ morphologyQuiz mt pgf lang typ
@@ -336,22 +320,13 @@ pgfCommands = Map.fromList [
"Shows all trees returned by parsing a string in the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"The default start category can be overridden by the -cat flag.",
"See also the ps command for lexing and character encoding.",
"",
"The -openclass flag is experimental and allows some robustness in ",
"the parser. For example if -openclass=\"A,N,V\" is given, the parser",
"will accept unknown adjectives, nouns and verbs with the resource grammar."
"See also the ps command for lexing and character encoding."
],
exec = needPGF $ \opts ts pgf mos ->
exec = needPGF $ \opts ts pgf ->
return $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
flags = [
("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)"),
("openclass","list of open-class categories for robust parsing"),
("depth","maximal depth for proof search if the abstract syntax tree has meta variables")
],
options = [
("bracket","prints the bracketed string from the parser")
("lang","the languages of parsing (comma-separated, no spaces)")
]
}),
@@ -374,7 +349,7 @@ pgfCommands = Map.fromList [
" " ++ opt ++ "\t\t" ++ expl |
((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
]),
exec = needPGF $ \opts _ pgf mos -> prGrammar pgf mos opts,
exec = needPGF $ \opts _ pgf -> prGrammar pgf opts,
flags = [
--"cat",
("file", "set the file name when printing with -pgf option"),
@@ -410,7 +385,7 @@ pgfCommands = Map.fromList [
examples = [
mkEx "pt -compute (plus one two) -- compute value"
],
exec = needPGF $ \opts arg pgf mos ->
exec = needPGF $ \opts arg pgf ->
returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
options = treeOpOptions undefined{-pgf-},
flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
@@ -430,7 +405,7 @@ pgfCommands = Map.fromList [
("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees")
],
exec = needPGF $ \ opts _ pgf mos -> do
exec = needPGF $ \ opts _ pgf -> do
let file = valStrOpts "file" "_gftmp" opts
let exprs [] = ([],empty)
exprs ((n,s):ls) | null s
@@ -439,7 +414,7 @@ pgfCommands = Map.fromList [
Just e -> let (es,err) = exprs ls
in case inferExpr pgf e of
Right (e,t) -> (e:es,err)
Left tcerr -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err)
Left err -> (es,"on line" <+> n <> ':' $$ nest 2 err $$ err)
Nothing -> let (es,err) = exprs ls
in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
returnFromLines ls = case exprs ls of
@@ -457,38 +432,13 @@ pgfCommands = Map.fromList [
flags = [("file","the input file name")]
}),
("rt", emptyCommandInfo {
longname = "rank_trees",
synopsis = "show trees in an order of decreasing probability",
explanation = unlines [
"Order trees from the most to the least probable, using either",
"even distribution in each category (default) or biased as specified",
"by the file given by flag -probs=FILE, where each line has the form",
"'function probability', e.g. 'youPol_Pron 0.01'."
],
exec = needPGF $ \ opts arg pgf mos -> do
let ts = toExprs arg
let tds = rankTreesByProbs pgf ts
if isOpt "v" opts
then putStrLn $
unlines [showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds]
else return ()
returnFromExprs $ map fst tds,
options = [
("v","show all trees with their probability scores")
],
examples = [
mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
]
}),
("tq", emptyCommandInfo {
longname = "translation_quiz",
syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
synopsis = "start a translation quiz",
exec = needPGF $ \ opts arg pgf mos -> do
let from = optLangFlag "from" pgf opts
let to = optLangFlag "to" pgf opts
exec = needPGF $ \ opts arg pgf -> do
from <- optLangFlag "from" pgf opts
to <- optLangFlag "to" pgf opts
let typ = optType pgf opts
let mt = mexp (toExprs arg)
restricted $ translationQuiz mt pgf from to typ
@@ -522,7 +472,7 @@ pgfCommands = Map.fromList [
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
"See also 'vp -showdep' for another visualization of dependencies."
],
exec = needPGF $ \ opts arg pgf mos -> do
exec = needPGF $ \ opts arg pgf -> do
let absname = abstractName pgf
let es = toExprs arg
let debug = isOpt "v" opts
@@ -535,8 +485,8 @@ pgfCommands = Map.fromList [
mclab <- case cnclabels of
"" -> return Nothing
_ -> (Just . getCncDepLabels) `fmap` restricted (readFile cnclabels)
let lang = optLang pgf opts
let grphs = map (graphvizDependencyTree outp debug mlab mclab pgf lang) es
concr <- optLang pgf opts
let grphs = map (graphvizDependencyTree outp debug mlab mclab concr) es
if isOpt "conll2latex" opts
then return $ fromString $ conlls2latexDoc $ stanzas $ unlines $ toStrings arg
else if isFlag "view" opts && valStrOpts "output" "" opts == "latex"
@@ -582,9 +532,8 @@ pgfCommands = Map.fromList [
"by the view flag. The target format is png, unless overridden by the",
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
],
exec = needPGF $ \ opts arg pgf mos -> do
let es = toExprs arg
let lang = optLang pgf opts
exec = needPGF $ \opts arg pgf -> do
let es = toExprs arg
let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
@@ -597,10 +546,11 @@ pgfCommands = Map.fromList [
leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
}
let depfile = valStrOpts "file" "" opts
concr <- optLang pgf opts
mlab <- case depfile of
"" -> return Nothing
_ -> (Just . getDepLabels) `fmap` restricted (readFile depfile)
let grphs = map (graphvizParseTreeDep mlab pgf lang gvOptions) es
let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es
if isFlag "view" opts || isFlag "format" opts
then do
let view = optViewGraph opts
@@ -647,7 +597,7 @@ pgfCommands = Map.fromList [
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
"With option -mk, use for showing library style function names of form 'mkC'."
],
exec = needPGF $ \ opts arg pgf mos ->
exec = needPGF $ \opts arg pgf ->
let es = toExprs arg in
if isOpt "mk" opts
then return $ fromString $ unlines $ map (tree2mk pgf) es
@@ -659,7 +609,7 @@ pgfCommands = Map.fromList [
else do
let funs = not (isOpt "nofun" opts)
let cats = not (isOpt "nocat" opts)
let grphs = map (graphvizAbstractTree pgf (funs,cats)) es
let grphs = map (graphvizAbstractTree pgf (graphvizDefaults{noFun=funs,noCat=cats})) es
if isFlag "view" opts || isFlag "format" opts
then do
let view = optViewGraph opts
@@ -694,7 +644,7 @@ pgfCommands = Map.fromList [
"If a whole expression is given it prints the expression with refined",
"metavariables and the type of the expression."
],
exec = needPGF $ \opts arg pgf mos -> do
exec = needPGF $ \opts arg pgf -> do
case toExprs arg of
[e] -> case unApp e of
Just (id, []) -> case functionType pgf id of
@@ -702,7 +652,7 @@ pgfCommands = Map.fromList [
putStrLn ("Probability: "++show (treeProbability pgf e))
return void
Nothing -> case categoryContext pgf id of
Just hypos -> do putStrLn ("cat "++showCId id++if null hypos then "" else ' ':showContext [] hypos)
Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos)
let ls = [showFun pgf fn ty | fn <- functionsByCat pgf id, Just ty <- [functionType pgf fn]]
if null ls
then return ()
@@ -712,7 +662,7 @@ pgfCommands = Map.fromList [
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
_ -> case inferExpr pgf e of
Left tcErr -> error $ render (ppTcError tcErr)
Left err -> error err
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
putStrLn ("Type: "++showType [] ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
@@ -724,14 +674,12 @@ pgfCommands = Map.fromList [
]
where
needPGF exec opts ts = do
Env mb_pgf mos <- getPGFEnv
mb_pgf <- getPGF
case mb_pgf of
Just pgf -> liftSIO $ exec opts ts pgf mos
Just pgf -> liftSIO $ exec opts ts pgf
_ -> fail "Import a grammar before using this command"
par pgf opts s = [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
where
dp = valIntOpts "depth" 4 opts
par pgf opts s = [parse concr (optType pgf opts) s | concr <- optLangs pgf opts]
fromParse opts = foldr (joinPiped . fromParse1 opts) void
@@ -740,49 +688,39 @@ pgfCommands = Map.fromList [
jA (Exprs es1) (Exprs es2) = Exprs (es1++es2)
-- ^ fromParse1 always output Exprs
fromParse1 opts (s,(po,bs))
| isOpt "bracket" opts = pipeMessage (showBracketedString bs)
| otherwise =
fromParse1 opts (s,po) =
case po of
ParseOk ts -> fromExprs ts
ParseFailed i -> pipeMessage $ "The parser failed at token "
ParseOk ts -> fromExprs (map fst ts)
ParseFailed i _ -> pipeMessage $ "The parser failed at token "
++ show i ++": "
++ show (words s !! max 0 (i-1))
-- ++ " in " ++ show s
ParseIncomplete -> pipeMessage "The sentence is not complete"
TypeError errs ->
pipeMessage . render $
"The parsing is successful but the type checking failed with error(s):"
$$ nest 2 (vcat (map (ppTcError . snd) errs))
optLins pgf opts ts = case opts of
_ | isOpt "groups" opts ->
concatMap snd $ groupResults
[[(lang, s) | lang <- optLangs pgf opts,s <- linear pgf opts lang t] | t <- ts]
_ -> concatMap (optLin pgf opts) ts
optLins pgf opts ts = concatMap (optLin pgf opts) ts
optLin pgf opts t =
case opts of
_ | isOpt "treebank" opts && isOpt "chunks" opts ->
(showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[showCId lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
(abstractName pgf ++ ": " ++ showExpr [] t) :
[lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
_ | isOpt "treebank" opts ->
(showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
(abstractName pgf ++ ": " ++ showExpr [] t) :
[concreteName concr ++ ": " ++ s | concr <- optLangs pgf opts, s<-linear opts concr t]
_ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t
_ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
_ -> [s | concr <- optLangs pgf opts, s <- linear opts concr t]
linChunks pgf opts t =
[(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts]
[(concreteName concr, unwords (intersperse "<+>" (map (unlines . linear opts concr) (treeChunks t)))) | concr <- optLangs pgf opts]
linear :: PGF -> [Option] -> CId -> Expr -> [String]
linear pgf opts lang = let unl = unlex opts lang in case opts of
_ | isOpt "all" opts -> concat . -- intersperse [[]] .
map (map (unl . snd)) . tabularLinearizes pgf lang
linear :: [Option] -> Concr -> Expr -> [String]
linear opts concr = case opts of
_ | isOpt "all" opts -> concat .
map (map snd) . tabularLinearizeAll concr
_ | isOpt "list" opts -> (:[]) . commaList . concat .
map (map (unl . snd)) . tabularLinearizes pgf lang
_ | isOpt "table" opts -> concat . -- intersperse [[]] .
map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang
_ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize pgf lang
_ -> (:[]) . unl . linearize pgf lang
map (map snd) . tabularLinearizeAll concr
_ | isOpt "table" opts -> concat .
map (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
_ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
_ -> (:[]) . linearize concr
-- replace each non-atomic constructor with mkC, where C is the val cat
tree2mk pgf = showExpr [] . t2m where
@@ -791,61 +729,38 @@ pgfCommands = Map.fromList [
_ -> t
mk f = case functionType pgf f of
Just ty -> let (_,cat,_) = unType ty
in mkCId ("mk" ++ showCId cat)
in "mk" ++ cat
Nothing -> f
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
lexs -> case lookup lang
[(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
Just le -> chunks ',' le
_ -> []
commaList [] = []
commaList ws = concat $ head ws : map (", " ++) (tail ws)
-- Proposed logic of coding in unlexing:
-- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used.
-- - If lang has flag coding=utf8, -to_utf8 is ignored.
-- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
{-
unlexx pgf opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ----
optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of
Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts
Just (LStr other) | isOpt "to_utf8" opts ->
let cod = ("from_" ++ other)
in cod : filter (/=cod) (map prOpt opts)
_ -> map prOpt opts
-}
optLang = optLangFlag "lang"
optLangs = optLangsFlag "lang"
optLangsFlag f pgf opts = case valStrOpts f "" opts of
"" -> languages pgf
lang -> map (completeLang pgf) (chunks ',' lang)
completeLang pgf la = let cla = (mkCId la) in
if elem cla (languages pgf)
then cla
else (mkCId (showCId (abstractName pgf) ++ la))
optLangFlag flag pgf opts =
case optLangsFlag flag pgf opts of
[] -> fail "no language specified"
(l:ls) -> return l
optLangsFlag flag pgf opts =
case valStrOpts flag "" opts of
"" -> Map.elems langs
str -> mapMaybe (completeLang pgf) (chunks ',' str)
where
langs = languages pgf
completeLang pgf la =
mplus (Map.lookup la langs)
(Map.lookup (abstractName pgf ++ la) langs)
optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId]
{-
optProbs opts pgf = case valStrOpts "probs" "" opts of
"" -> return pgf
file -> do
probs <- restricted $ readProbabilitiesFromFile file pgf
return (setProbabilities probs pgf)
-}
optFile opts = valStrOpts "file" "_gftmp" opts
optType pgf opts =
let readOpt str = case readType str of
Just ty -> case checkType pgf ty of
Left tcErr -> error $ render (ppTcError tcErr)
Right ty -> ty
Left err -> error err
Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as a type")
in maybeStrOpts "cat" (startCat pgf) readOpt opts
optViewFormat opts = valStrOpts "format" "png" opts
@@ -858,35 +773,31 @@ pgfCommands = Map.fromList [
[] -> pipeMessage "no trees found"
_ -> fromExprs es
prGrammar pgf mos opts
prGrammar pgf opts
| isOpt "pgf" opts = do
let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
let outfile = valStrOpts "file" (abstractName pgf ++ ".pgf") opts
restricted $ writePGF outfile pgf
putStrLn $ "wrote file " ++ outfile
return void
| isOpt "cats" opts = return $ fromString $ unwords $ map showCId $ categories pgf
| isOpt "cats" opts = return $ fromString $ unwords $ categories pgf
| isOpt "funs" opts = return $ fromString $ unlines [showFun pgf f ty | f <- functions pgf, Just ty <- [functionType pgf f]]
| isOpt "fullform" opts = return $ fromString $ concatMap (morpho mos "" prFullFormLexicon) $ optLangs pgf opts
| isOpt "langs" opts = return $ fromString $ unwords $ map showCId $ languages pgf
| isOpt "fullform" opts = return $ fromString $ concatMap prFullFormLexicon $ optLangs pgf opts
| isOpt "langs" opts = return $ fromString $ unwords $ Map.keys $ languages pgf
| isOpt "lexc" opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":":[showCId f | f <- functions pgf, not (hasLinearization pgf la f)]) |
la <- optLangs pgf opts]
| isOpt "words" opts = return $ fromString $ concatMap (morpho mos "" prAllWords) $ optLangs pgf opts
| isOpt "lexc" opts = return $ fromString $ concatMap prLexcLexicon $ optLangs pgf opts
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (concreteName concr:":":[f | f <- functions pgf, not (hasLinearization concr f)]) |
concr <- optLangs pgf opts]
| isOpt "words" opts = return $ fromString $ concatMap prAllWords $ optLangs pgf opts
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
showFun pgf id ty = kwd++" "++showCId id ++ " : " ++ showType [] ty
showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
where
kwd | functionIsDataCon pgf id = "data"
| otherwise = "fun"
morphos pgf mos opts s =
[(s,morpho mos [] (\mo -> lookupMorpho mo s) la) | la <- optLangs pgf opts]
morpho mos z f la = maybe z f $ Map.lookup la mos
optMorpho pgf mos opts = morpho mos (error "no morpho") id (head (optLangs pgf opts))
morphos pgf opts s =
[(s,lookupMorpho concr s) | concr <- optLangs pgf opts]
optClitics opts = case valStrOpts "clitics" "" opts of
"" -> []
@@ -899,18 +810,28 @@ pgfCommands = Map.fromList [
-- ps -f -g s returns g (f s)
treeOps pgf opts s = foldr app s (reverse opts) where
app (OOpt op) | Just (Left f) <- treeOp pgf op = f
app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x)
app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x
app _ = id
morphoMissing :: Concr -> [String] -> [String]
morphoMissing = morphoClassify False
morphoKnown :: Concr -> [String] -> [String]
morphoKnown = morphoClassify True
morphoClassify :: Bool -> Concr -> [String] -> [String]
morphoClassify k concr ws = [w | w <- ws, k /= null (lookupMorpho concr w), notLiteral w] where
notLiteral w = not (all isDigit w)
treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf]
treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO ()
translationQuiz :: Maybe Expr -> PGF -> Concr -> Concr -> Type -> IO ()
translationQuiz mex pgf ig og typ = do
tts <- translationList mex pgf ig og typ infinity
mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO ()
morphologyQuiz :: Maybe Expr -> PGF -> Concr -> Type -> IO ()
morphologyQuiz mex pgf ig typ = do
tts <- morphologyList mex pgf ig typ infinity
mkQuiz "Welcome to GF Morphology Quiz." tts
@@ -919,28 +840,28 @@ morphologyQuiz mex pgf ig typ = do
infinity :: Int
infinity = 256
prLexcLexicon :: Morpho -> String
prLexcLexicon mo =
unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"]
prLexcLexicon :: Concr -> String
prLexcLexicon concr =
unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
where
morpho = fullFormLexicon mo
prLexc l p = showCId l ++ concat (mkTags (words p))
morpho = fullFormLexicon concr
prLexc l p = l ++ concat (mkTags (words p))
mkTags p = case p of
"s":ws -> mkTags ws --- remove record field
ws -> map ('+':) ws
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p) <- lps]
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
prFullFormLexicon :: Morpho -> String
prFullFormLexicon mo =
unlines (map prMorphoAnalysis (fullFormLexicon mo))
prFullFormLexicon :: Concr -> String
prFullFormLexicon concr =
unlines (map prMorphoAnalysis (fullFormLexicon concr))
prAllWords :: Morpho -> String
prAllWords mo =
unwords [w | (w,_) <- fullFormLexicon mo]
prAllWords :: Concr -> String
prAllWords concr =
unwords [w | (w,_) <- fullFormLexicon concr]
prMorphoAnalysis (w,lps) =
unlines (w:[showCId l ++ " : " ++ p | (l,p) <- lps])
unlines (w:[l ++ " : " ++ p ++ show prob | (l,p,prob) <- lps])
viewGraphviz :: String -> String -> String -> [String] -> SIO CommandOutput
viewGraphviz view format name grphs = do

822
src/compiler/GF/Command/Commands2.hs
View File

@@ -1,822 +0,0 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands2 (
PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands,
options, flags,
) where
import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF2
import qualified PGF as H
import GF.Compile.ToAPI(exprToAPI)
import GF.Infra.UseIO(writeUTF8File)
import GF.Infra.SIO(MonadSIO,liftSIO,putStrLn,restricted,restrictedSystem)
import GF.Command.Abstract
import GF.Command.CommandInfo
import GF.Data.Operations
import Data.List(intersperse,intersect,nub,sortBy)
import Data.Maybe
import qualified Data.Map as Map
import GF.Text.Pretty
import Control.Monad(mplus)
data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr}
pgfEnv pgf = Env (Just pgf) (languages pgf)
emptyPGFEnv = Env Nothing Map.empty
class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
instance (Monad m,HasPGFEnv m) => TypeCheckArg m where
typeCheckArg e = do env <- getPGFEnv
case pgf env of
Just gr -> either fail
(return . hsExpr . fst)
(inferExpr gr (cExpr e))
Nothing -> fail "Import a grammar before using this command"
pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
pgfCommands = Map.fromList [
("aw", emptyCommandInfo {
longname = "align_words",
synopsis = "show word alignments between languages graphically",
explanation = unlines [
"Prints a set of strings in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = needPGF $ \opts es env -> do
let cncs = optConcs env opts
if isOpt "giza" opts
then if length cncs == 2
then let giz = map (gizaAlignment pgf (snd (cncs !! 0)) (snd (cncs !! 1)) . cExpr) (toExprs es)
lsrc = unlines $ map (\(x,_,_) -> x) giz
ltrg = unlines $ map (\(_,x,_) -> x) giz
align = unlines $ map (\(_,_,x) -> x) giz
grph = if null (toExprs es) then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
in return (fromString grph)
else error "For giza alignment you need exactly two languages"
else let gvOptions=graphvizDefaults{leafFont = valStrOpts "font" "" opts,
leafColor = valStrOpts "color" "" opts,
leafEdgeStyle = valStrOpts "edgestyle" "" opts
}
grph = if null (toExprs es) then [] else graphvizWordAlignment (map snd cncs) gvOptions (cExpr (head (toExprs es)))
in if isFlag "view" opts || isFlag "format" opts
then do let file s = "_grph." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grph
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return (fromString grph),
examples = [
("gr | aw" , "generate a tree and show word alignment as graph script"),
("gr | aw -view=\"open\"" , "generate a tree and display alignment on Mac"),
("gr | aw -view=\"eog\"" , "generate a tree and display alignment on Ubuntu"),
("gt | aw -giza | wf -file=aligns" , "generate trees, send giza alignments to file")
],
options = [
("giza", "show alignments in the Giza format; the first two languages")
],
flags = [
("format","format of the visualization file (default \"png\")"),
("lang", "alignments for this list of languages (default: all)"),
("view", "program to open the resulting file"),
("font", "font for the words"),
("color", "color for the words"),
("edgestyle", "the style for links between words")
]
}),
{-
("eb", emptyCommandInfo {
longname = "example_based",
syntax = "eb (-probs=FILE | -lang=LANG)* -file=FILE.gfe",
synopsis = "converts .gfe files to .gf files by parsing examples to trees",
explanation = unlines [
"Reads FILE.gfe and writes FILE.gf. Each expression of form",
"'%ex CAT QUOTEDSTRING' in FILE.gfe is replaced by a syntax tree.",
"This tree is the first one returned by the parser; a biased ranking",
"can be used to regulate the order. If there are more than one parses",
"the rest are shown in comments, with probabilities if the order is biased.",
"The probabilities flag and configuration file is similar to the commands",
"gr and rt. Notice that the command doesn't change the environment,",
"but the resulting .gf file must be imported separately."
],
options = [
("api","convert trees to overloaded API expressions (using Syntax not Lang)")
],
flags = [
("file","the file to be converted (suffix .gfe must be given)"),
("lang","the language in which to parse"),
("probs","file with probabilities to rank the parses")
],
exec = \env@(pgf, mos) opts _ -> do
let file = optFile opts
pgf <- optProbs opts pgf
let printer = if (isOpt "api" opts) then exprToAPI else (H.showExpr [])
let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
(file',ws) <- restricted $ parseExamplesInGrammar conf file
if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
return (fromString ("wrote " ++ file')),
needsTypeCheck = False
}),
-}
{-
("gr", emptyCommandInfo {
longname = "generate_random",
synopsis = "generate random trees in the current abstract syntax",
syntax = "gr [-cat=CAT] [-number=INT]",
examples = [
mkEx "gr -- one tree in the startcat of the current grammar",
mkEx "gr -cat=NP -number=16 -- 16 trees in the category NP",
mkEx "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha",
mkEx "gr -probs=FILE -- generate with bias",
mkEx "gr (AdjCN ? (UseN ?)) -- generate trees of form (AdjCN ? (UseN ?))"
],
explanation = unlines [
"Generates a list of random trees, by default one tree.",
"If a tree argument is given, the command completes the Tree with values to",
"all metavariables in the tree. The generation can be biased by probabilities,",
"given in a file in the -probs flag."
],
flags = [
("cat","generation category"),
("lang","uses only functions that have linearizations in all these languages"),
("number","number of trees generated"),
("depth","the maximum generation depth"),
("probs", "file with biased probabilities (format 'f 0.4' one by line)")
],
exec = \env@(pgf, mos) opts xs -> do
pgf <- optProbs opts (optRestricted opts pgf)
gen <- newStdGen
let dp = valIntOpts "depth" 4 opts
let ts = case mexp xs of
Just ex -> H.generateRandomFromDepth gen pgf ex (Just dp)
Nothing -> H.generateRandomDepth gen pgf (optType pgf opts) (Just dp)
returnFromExprs $ take (optNum opts) ts
}),
-}
("gt", emptyCommandInfo {
longname = "generate_trees",
synopsis = "generates a list of trees, by default exhaustive",
flags = [("cat","the generation category"),
("number","the number of trees generated")],
examples = [
mkEx "gt -- all trees in the startcat",
mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP"],
exec = needPGF $ \ opts _ env@(pgf,_) ->
let ts = map fst (generateAll pgf cat)
cat = optType pgf opts
in returnFromCExprs (takeOptNum opts ts),
needsTypeCheck = False
}),
("i", emptyCommandInfo {
longname = "import",
synopsis = "import a grammar from a compiled .pgf file",
explanation = unlines [
"Reads a grammar from a compiled .pgf file.",
"Old modules are discarded.",
{-
"The grammar parser depends on the file name suffix:",
" .cf context-free (labelled BNF) source",
" .ebnf extended BNF source",
" .gfm multi-module GF source",
" .gf normal GF source",
" .gfo compiled GF source",
-}
" .pgf precompiled grammar in Portable Grammar Format"
],
flags = [
-- ("probs","file with biased probabilities for generation")
],
options = [
-- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
-- ("retain","retain operations (used for cc command)"),
-- ("src", "force compilation from source"),
-- ("v", "be verbose - show intermediate status information")
],
needsTypeCheck = False
}),
("l", emptyCommandInfo {
longname = "linearize",
synopsis = "convert an abstract syntax expression to string",
explanation = unlines [
"Shows the linearization of a Tree by the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"A sequence of string operations (see command ps) can be given",
"as options, and works then like a pipe to the ps command, except",
"that it only affect the strings, not e.g. the table labels.",
"These can be given separately to each language with the unlexer flag",
"whose results are prepended to the other lexer flags. The value of the",
"unlexer flag is a space-separated list of comma-separated string operation",
"sequences; see example."
],
examples = [
mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize a tree to LangSwe and LangNor",
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
],
exec = needPGF $ \ opts arg env ->
return . fromStrings . optLins env opts . map cExpr $ toExprs arg,
options = [
("all", "show all forms and variants, one by line (cf. l -list)"),
("bracket","show tree structure with brackets and paths to nodes"),
("groups", "all languages, grouped by lang, remove duplicate strings"),
("list","show all forms and variants, comma-separated on one line (cf. l -all)"),
("multi","linearize to all languages (default)"),
("table","show all forms labelled by parameters"),
("treebank","show the tree and tag linearizations with language names")
],
flags = [
("lang","the languages of linearization (comma-separated, no spaces)")
]
}),
("ma", emptyCommandInfo {
longname = "morpho_analyse",
synopsis = "print the morphological analyses of the (multiword) expression in the string",
explanation = unlines [
"Prints all the analyses of the (multiword) expression in the input string,",
"using the morphological analyser of the actual grammar (see command pg)"
],
exec = needPGF $ \opts args env ->
return ((fromString . unlines .
map prMorphoAnalysis . concatMap (morphos env opts) . toStrings) args),
flags = [
("lang","the languages of analysis (comma-separated, no spaces)")
]
}),
{-
("mq", emptyCommandInfo {
longname = "morpho_quiz",
synopsis = "start a morphology quiz",
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
exec = \env@(pgf, mos) opts xs -> do
let lang = optLang pgf opts
let typ = optType pgf opts
pgf <- optProbs opts pgf
let mt = mexp xs
restricted $ morphologyQuiz mt pgf lang typ
return void,
flags = [
("lang","language of the quiz"),
("cat","category of the quiz"),
("number","maximum number of questions"),
("probs","file with biased probabilities for generation")
]
}),
-}
("p", emptyCommandInfo {
longname = "parse",
synopsis = "parse a string to abstract syntax expression",
explanation = unlines [
"Shows all trees returned by parsing a string in the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"The default start category can be overridden by the -cat flag.",
"See also the ps command for lexing and character encoding."
],
flags = [
("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)"),
("number","maximum number of trees returned")
],
examples = [
mkEx "p \"this fish is fresh\" | l -lang=Swe -- try parsing with all languages and translate the successful parses to Swedish"
],
exec = needPGF $ \ opts ts env -> return . cParse env opts $ toStrings ts
}),
("pg", emptyCommandInfo {
longname = "print_grammar",
synopsis = "prints different information about the grammar",
exec = needPGF $ \opts _ env -> prGrammar env opts,
options = [
("cats", "show just the names of abstract syntax categories"),
("fullform", "print the fullform lexicon"),
("funs", "show just the names and types of abstract syntax functions"),
("langs", "show just the names of top concrete syntax modules"),
("lexc", "print the lexicon in Xerox LEXC format"),
("missing","show just the names of functions that have no linearization"),
("words", "print the list of words")
],
flags = [
("lang","the languages that need to be printed")
],
examples = [
mkEx "pg -langs -- show the names of top concrete syntax modules",
mkEx "pg -funs | ? grep \" S ;\" -- show functions with value cat S"
]
}),
{-
("pt", emptyCommandInfo {
longname = "put_tree",
syntax = "pt OPT? TREE",
synopsis = "return a tree, possibly processed with a function",
explanation = unlines [
"Returns a tree obtained from its argument tree by applying",
"tree processing functions in the order given in the command line",
"option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors",
"are type checking and semantic computation."
],
examples = [
mkEx "pt -compute (plus one two) -- compute value",
mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..."
],
exec = \env@(pgf, mos) opts ->
returnFromExprs . takeOptNum opts . treeOps pgf opts,
options = treeOpOptions undefined{-pgf-},
flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
}),
-}
("rf", emptyCommandInfo {
longname = "read_file",
synopsis = "read string or tree input from a file",
explanation = unlines [
"Reads input from file. The filename must be in double quotes.",
"The input is interpreted as a string by default, and can hence be",
"piped e.g. to the parse command. The option -tree interprets the",
"input as a tree, which can be given e.g. to the linearize command.",
"The option -lines will result in a list of strings or trees, one by line."
],
options = [
("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees")
],
exec = needPGF $ \opts _ env@(pgf, mos) -> do
let file = optFile opts
let exprs [] = ([],empty)
exprs ((n,s):ls) | null s
= exprs ls
exprs ((n,s):ls) = case readExpr s of
Just e -> let (es,err) = exprs ls
in case inferExpr pgf e of
Right (e,t) -> (e:es,err)
Left msg -> (es,"on line" <+> n <> ':' $$ msg $$ err)
Nothing -> let (es,err) = exprs ls
in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
returnFromLines ls = case exprs ls of
(es, err) | null es -> return $ pipeMessage $ render (err $$ "no trees found")
| otherwise -> return $ pipeWithMessage (map hsExpr es) (render err)
s <- restricted $ readFile file
case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
returnFromLines (zip [1::Int ..] (lines s))
_ | isOpt "tree" opts ->
returnFromLines [(1::Int,s)]
_ | isOpt "lines" opts -> return (fromStrings $ lines s)
_ -> return (fromString s),
flags = [("file","the input file name")]
}),
("rt", emptyCommandInfo {
longname = "rank_trees",
synopsis = "show trees in an order of decreasing probability",
explanation = unlines [
"Order trees from the most to the least probable, using either",
"even distribution in each category (default) or biased as specified",
"by the file given by flag -probs=FILE, where each line has the form",
"'function probability', e.g. 'youPol_Pron 0.01'."
],
exec = needPGF $ \opts es env@(pgf, _) -> do
let tds = sortBy (\(_,p) (_,q) -> compare p q)
[(t, treeProbability pgf t) | t <- map cExpr (toExprs es)]
if isOpt "v" opts
then putStrLn $
unlines [PGF2.showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds]
else return ()
returnFromExprs $ map (hsExpr . fst) tds,
flags = [
("probs","probabilities from this file (format 'f 0.6' per line)")
],
options = [
("v","show all trees with their probability scores")
],
examples = [
mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
]
}),
{-
("tq", emptyCommandInfo {
longname = "translation_quiz",
syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
synopsis = "start a translation quiz",
exec = \env@(pgf, mos) opts xs -> do
let from = optLangFlag "from" pgf opts
let to = optLangFlag "to" pgf opts
let typ = optType pgf opts
let mt = mexp xs
pgf <- optProbs opts pgf
restricted $ translationQuiz mt pgf from to typ
return void,
flags = [
("from","translate from this language"),
("to","translate to this language"),
("cat","translate in this category"),
("number","the maximum number of questions"),
("probs","file with biased probabilities for generation")
],
examples = [
mkEx ("tq -from=Eng -to=Swe -- any trees in startcat"),
mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form")
]
}),
("vd", emptyCommandInfo {
longname = "visualize_dependency",
synopsis = "show word dependency tree graphically",
explanation = unlines [
"Prints a dependency tree in the .dot format (the graphviz format, default)",
"or the CoNLL/MaltParser format (flag -output=conll for training, malt_input",
"for unanalysed input).",
"By default, the last argument is the head of every abstract syntax",
"function; moreover, the head depends on the head of the function above.",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is png, unless overridden by the",
"flag -format."
],
exec = \env@(pgf, mos) opts es -> do
let debug = isOpt "v" opts
let file = valStrOpts "file" "" opts
let outp = valStrOpts "output" "dot" opts
mlab <- case file of
"" -> return Nothing
_ -> (Just . H.getDepLabels . lines) `fmap` restricted (readFile file)
let lang = optLang pgf opts
let grphs = unlines $ map (H.graphvizDependencyTree outp debug mlab Nothing pgf lang) es
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grphd." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grphs
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return $ fromString grphs,
examples = [
mkEx "gr | vd -- generate a tree and show dependency tree in .dot",
mkEx "gr | vd -view=open -- generate a tree and display dependency tree on a Mac",
mkEx "gr -number=1000 | vd -file=dep.labels -output=malt -- generate training treebank",
mkEx "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences"
],
options = [
("v","show extra information")
],
flags = [
("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"),
("format","format of the visualization file (default \"png\")"),
("output","output format of graph source (default \"dot\")"),
("view","program to open the resulting file (default \"open\")"),
("lang","the language of analysis")
]
}),
-}
("vp", emptyCommandInfo {
longname = "visualize_parse",
synopsis = "show parse tree graphically",
explanation = unlines [
"Prints a parse tree in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is png, unless overridden by the",
"flag -format."
],
exec = needPGF $ \opts arg env@(pgf, concs) ->
do let es = toExprs arg
let concs = optConcs env opts
let gvOptions=graphvizDefaults{noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
nodeFont = valStrOpts "nodefont" "" opts,
leafFont = valStrOpts "leaffont" "" opts,
nodeColor = valStrOpts "nodecolor" "" opts,
leafColor = valStrOpts "leafcolor" "" opts,
nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
}
let grph= if null es || null concs
then []
else graphvizParseTree (snd (head concs)) gvOptions (cExpr (head es))
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grph
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return $ fromString grph,
examples = [
mkEx "p -lang=Eng \"John walks\" | vp -- generate a tree and show parse tree as .dot script",
mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac"
],
options = [
("showcat","show categories in the tree nodes (default)"),
("nocat","don't show categories"),
("showfun","show function names in the tree nodes"),
("nofun","don't show function names (default)"),
("showleaves","show the leaves of the tree (default)"),
("noleaves","don't show the leaves of the tree (i.e., only the abstract tree)")
],
flags = [
("lang","the language to visualize"),
("format","format of the visualization file (default \"png\")"),
("view","program to open the resulting file (default \"open\")"),
("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
("leaffont","font for tree leaves (default: nodefont)"),
("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
("leafcolor","color for tree leaves (default: nodecolor)"),
("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)"),
("leafedgestyle","edge style for links to leaves (solid/dashed/dotted/bold, default: dashed)")
]
}),
("vt", emptyCommandInfo {
longname = "visualize_tree",
synopsis = "show a set of trees graphically",
explanation = unlines [
"Prints a set of trees in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = needPGF $ \opts arg env@(pgf, _) ->
let es = toExprs arg in
if isOpt "api" opts
then do
mapM_ (putStrLn . exprToAPI) es
return void
else do
let gvOptions=graphvizDefaults{noFun = isOpt "nofun" opts,
noCat = isOpt "nocat" opts,
nodeFont = valStrOpts "nodefont" "" opts,
nodeColor = valStrOpts "nodecolor" "" opts,
nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts
}
let grph = unlines (map (graphvizAbstractTree pgf gvOptions . cExpr) es)
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts
let format = optViewFormat opts
restricted $ writeUTF8File (file "dot") grph
restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
restrictedSystem $ view ++ " " ++ file format
return void
else return $ fromString grph,
examples = [
mkEx "p \"hello\" | vt -- parse a string and show trees as graph script",
mkEx "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac"
],
options = [
("api", "show the tree with function names converted to 'mkC' with value cats C"),
("nofun","don't show functions but only categories"),
("nocat","don't show categories but only functions")
],
flags = [
("format","format of the visualization file (default \"png\")"),
("view","program to open the resulting file (default \"open\")"),
("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)")
]
}),
("ai", emptyCommandInfo {
longname = "abstract_info",
syntax = "ai IDENTIFIER or ai EXPR",
synopsis = "Provides an information about a function, an expression or a category from the abstract syntax",
explanation = unlines [
"The command has one argument which is either function, expression or",
"a category defined in the abstract syntax of the current grammar. ",
"If the argument is a function then its type is printed out.",
"If it is a category then the category definition is printed.",
"If a whole expression is given it prints the expression with refined",
"metavariables and the type of the expression."
],
exec = needPGF $ \opts args env@(pgf,cncs) ->
case map cExpr (toExprs args) of
[e] -> case unApp e of
Just (id,[]) -> return (fromString
(case functionType pgf id of
Just ty -> showFun id ty
Nothing -> let funs = functionsByCat pgf id
in showCat id funs))
where
showCat c funs = "cat "++c++
" ;\n\n"++
unlines [showFun f ty| f<-funs,
Just ty <- [functionType pgf f]]
showFun f ty = "fun "++f++" : "++showType [] ty++" ;"
_ -> case inferExpr pgf e of
Left msg -> error msg
Right (e,ty) -> do putStrLn ("Expression: "++PGF2.showExpr [] e)
putStrLn ("Type: "++PGF2.showType [] ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
return void
_ -> do putStrLn "a single function name or category name is expected"
return void,
needsTypeCheck = False
})
]
where
cParse env@(pgf,_) opts ss =
parsed [ parse cnc cat s | s<-ss,(lang,cnc)<-cncs]
where
cat = optType pgf opts
cncs = optConcs env opts
parsed rs = Piped (Exprs ts,unlines msgs)
where
ts = [hsExpr t|ParseOk ts<-rs,(t,p)<-takeOptNum opts ts]
msgs = concatMap mkMsg rs
mkMsg (ParseOk ts) = (map (PGF2.showExpr [] . fst).takeOptNum opts) ts
mkMsg (ParseFailed _ tok) = ["Parse failed: "++tok]
mkMsg (ParseIncomplete) = ["The sentence is incomplete"]
optLins env opts ts = case opts of
_ | isOpt "groups" opts ->
concatMap snd $ groupResults
[[(lang, s) | (lang,concr) <- optConcs env opts,s <- linear opts lang concr t] | t <- ts]
_ -> concatMap (optLin env opts) ts
optLin env@(pgf,_) opts t =
case opts of
_ | isOpt "treebank" opts ->
(abstractName pgf ++ ": " ++ PGF2.showExpr [] t) :
[lang ++ ": " ++ s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t]
_ -> [s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t]
linear :: [Option] -> ConcName -> Concr -> PGF2.Expr -> [String]
linear opts lang concr = case opts of
_ | isOpt "all" opts -> concat . map (map snd) . tabularLinearizeAll concr
_ | isOpt "list" opts -> (:[]) . commaList .
concatMap (map snd) . tabularLinearizeAll concr
_ | isOpt "table" opts -> concatMap (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
_ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
_ -> (:[]) . linearize concr
groupResults :: [[(ConcName,String)]] -> [(ConcName,[String])]
groupResults = Map.toList . foldr more Map.empty . start . concat
where
start ls = [(l,[s]) | (l,s) <- ls]
more (l,s) =
Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
optConcs = optConcsFlag "lang"
optConcsFlag f (pgf,cncs) opts =
case valStrOpts f "" opts of
"" -> Map.toList cncs
lang -> mapMaybe pickLang (chunks ',' lang)
where
pickLang l = pick l `mplus` pick fl
where
fl = abstractName pgf++l
pick l = (,) l `fmap` Map.lookup l cncs
{-
-- replace each non-atomic constructor with mkC, where C is the val cat
tree2mk pgf = H.showExpr [] . t2m where
t2m t = case H.unApp t of
Just (cid,ts@(_:_)) -> H.mkApp (mk cid) (map t2m ts)
_ -> t
mk = H.mkCId . ("mk" ++) . H.showCId . H.lookValCat (H.abstract pgf)
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
lexs -> case lookup lang
[(H.mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
Just le -> chunks ',' le
_ -> []
-}
commaList [] = []
commaList ws = concat $ head ws : map (", " ++) (tail ws)
optFile opts = valStrOpts "file" "_gftmp" opts
optType pgf opts =
case listFlags "cat" opts of
v:_ -> let str = valueString v
in case readType str of
Just ty -> case checkType pgf ty of
Left msg -> error msg
Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as a type")
_ -> startCat pgf
optViewFormat opts = valStrOpts "format" "png" opts
optViewGraph opts = valStrOpts "view" "open" opts
{-
optNum opts = valIntOpts "number" 1 opts
-}
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
takeOptNum opts = take (optNumInf opts)
returnFromCExprs = returnFromExprs . map hsExpr
returnFromExprs es =
return $ case es of
[] -> pipeMessage "no trees found"
_ -> fromExprs es
prGrammar env@(pgf,cncs) opts
| isOpt "langs" opts = return . fromString . unwords $ (map fst (optConcs env opts))
| isOpt "cats" opts = return . fromString . unwords $ categories pgf
| isOpt "funs" opts = return . fromString . unwords $ functions pgf
| isOpt "missing" opts = return . fromString . unwords $
[f | f <- functions pgf, not (and [hasLinearization concr f | (_,concr) <- optConcs env opts])]
| isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . snd) $ optConcs env opts
| isOpt "words" opts = return $ fromString $ concatMap (prAllWords . snd) $ optConcs env opts
| isOpt "lexc" opts = return $ fromString $ concatMap (prLexcLexicon . snd) $ optConcs env opts
| otherwise = return void
gizaAlignment pgf src_cnc tgt_cnc e =
let src_res = alignWords src_cnc e
tgt_res = alignWords tgt_cnc e
alignment = [show i++"-"++show j | (i,(_,src_fids)) <- zip [0..] src_res, (j,(_,tgt_fids)) <- zip [0..] tgt_res, not (null (intersect src_fids tgt_fids))]
in (unwords (map fst src_res), unwords (map fst tgt_res), unwords alignment)
morphos env opts s =
[(s,res) | (lang,concr) <- optConcs env opts, let res = lookupMorpho concr s, not (null res)]
{-
mexp xs = case xs of
t:_ -> Just t
_ -> Nothing
-}
-- ps -f -g s returns g (f s)
{-
treeOps pgf opts s = foldr app s (reverse opts) where
app (OOpt op) | Just (Left f) <- treeOp pgf op = f
app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (H.mkCId x)
app _ = id
treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf]
treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
translationQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Language -> H.Type -> IO ()
translationQuiz mex pgf ig og typ = do
tts <- translationList mex pgf ig og typ infinity
mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Type -> IO ()
morphologyQuiz mex pgf ig typ = do
tts <- morphologyList mex pgf ig typ infinity
mkQuiz "Welcome to GF Morphology Quiz." tts
-- | the maximal number of precompiled quiz problems
infinity :: Int
infinity = 256
-}
prLexcLexicon :: Concr -> String
prLexcLexicon concr =
unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
where
morpho = fullFormLexicon concr
prLexc l p = l ++ concat (mkTags (words p))
mkTags p = case p of
"s":ws -> mkTags ws --- remove record field
ws -> map ('+':) ws
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
-- thick_A+(AAdj+Posit+Gen):thick's # ;
prFullFormLexicon :: Concr -> String
prFullFormLexicon concr =
unlines (map prMorphoAnalysis (fullFormLexicon concr))
prAllWords :: Concr -> String
prAllWords concr =
unwords [w | (w,_) <- fullFormLexicon concr]
prMorphoAnalysis :: (String,[MorphoAnalysis]) -> String
prMorphoAnalysis (w,lps) =
unlines (w:[fun ++ " : " ++ cat | (fun,cat,p) <- lps])
hsExpr c =
case unApp c of
Just (f,cs) -> H.mkApp (H.mkCId f) (map hsExpr cs)
_ -> case unStr c of
Just str -> H.mkStr str
_ -> error $ "GF.Command.Commands2.hsExpr "++show c
cExpr e =
case H.unApp e of
Just (f,es) -> mkApp (H.showCId f) (map cExpr es)
_ -> case H.unStr e of
Just str -> mkStr str
_ -> error $ "GF.Command.Commands2.cExpr "++show e
needPGF exec opts ts =
do Env mb_pgf cncs <- getPGFEnv
case mb_pgf of
Just pgf -> liftSIO $ exec opts ts (pgf,cncs)
_ -> fail "Import a grammar before using this command"

24
src/compiler/GF/Command/CommonCommands.hs
View File

@@ -15,7 +15,7 @@ import GF.Text.Pretty
import GF.Text.Transliterations
import GF.Text.Lexing(stringOp,opInEnv)
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
import PGF2(showExpr)
extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
@@ -101,9 +101,7 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
"To see transliteration tables, use command ut."
],
examples = [
-- mkEx "l (EAdd 3 4) | ps -code -- linearize code-like output",
mkEx "l (EAdd 3 4) | ps -unlexcode -- linearize code-like output",
-- mkEx "ps -lexer=code | p -cat=Exp -- parse code-like input",
mkEx "ps -lexcode | p -cat=Exp -- parse code-like input",
mkEx "gr -cat=QCl | l | ps -bind -- linearization output from LangFin",
mkEx "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal",
@@ -175,12 +173,6 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
mkEx "gt | l | ? wc -- generate trees, linearize, and count words"
]
}),
("tt", emptyCommandInfo {
longname = "to_trie",
syntax = "to_trie",
synopsis = "combine a list of trees into a trie",
exec = \ _ -> return . fromString . trie . toExprs
}),
("ut", emptyCommandInfo {
longname = "unicode_table",
synopsis = "show a transliteration table for a unicode character set",
@@ -228,7 +220,6 @@ envFlag fs =
_ -> Nothing
stringOpOptions = sort $ [
("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
("chars","lexer that makes every non-space character a token"),
("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
("from_utf8","decode from utf8 (default)"),
@@ -253,19 +244,6 @@ stringOpOptions = sort $ [
("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] |
(p,n) <- transliterationPrintNames]
trie = render . pptss . H.toTrie . map H.toATree
where
pptss [ts] = "*"<+>nest 2 (ppts ts)
pptss tss = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss]
ppts = vcat . map ppt
ppt t =
case t of
H.Oth e -> pp (H.showExpr [] e)
H.Ap f [[]] -> pp (H.showCId f)
H.Ap f tss -> H.showCId f $$ nest 2 (pptss tss)
-- ** Converting command input
toString = unwords . toStrings
toLines = unlines . toStrings

4
src/compiler/GF/Command/Importing.hs
View File

@@ -1,7 +1,7 @@
module GF.Command.Importing (importGrammar, importSource) where
import PGF
import PGF.Internal(unionPGF)
import PGF2
import PGF2.Internal(unionPGF)
import GF.Compile
import GF.Compile.Multi (readMulti)

2
src/compiler/GF/Command/Interpreter.hs
View File

@@ -6,8 +6,8 @@ module GF.Command.Interpreter (
import GF.Command.CommandInfo
import GF.Command.Abstract
import GF.Command.Parse
import PGF
import GF.Infra.UseIO(putStrLnE)
import PGF2
import Control.Monad(when)
import qualified Data.Map as Map

10
src/compiler/GF/Command/Parse.hs
View File

@@ -1,6 +1,6 @@
module GF.Command.Parse(readCommandLine, pCommand) where
import PGF(pExpr,pIdent)
import PGF2(pExpr,pIdent)
import GF.Grammar.Parser(runPartial,pTerm)
import GF.Command.Abstract
@@ -22,7 +22,7 @@ pCommandLine =
pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
pCommand = (do
cmd <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
cmd <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent))
skipSpaces
opts <- sepBy pOption skipSpaces
arg <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
@@ -37,7 +37,7 @@ pCommand = (do
pOption = do
char '-'
flg <- pIdent
flg <- readS_to_P pIdent
option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
pValue = do
@@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
pArgument =
option ANoArg
(fmap AExpr pExpr
(fmap AExpr (readS_to_P pExpr)
<++
(skipSpaces >> char '%' >> fmap AMacro pIdent))
(skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
pArgTerm = ATerm `fmap` readS_to_P sTerm
where

6
src/compiler/GF/Command/TreeOperations.hs
View File

@@ -4,15 +4,15 @@ module GF.Command.TreeOperations (
treeChunks
) where
import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
import Data.List
type TreeOp = [Expr] -> [Expr]
treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp))
treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))]
allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
Left $ map (compute pgf))),

2
src/compiler/GF/Compile.hs
View File

@@ -22,7 +22,7 @@ import Data.List(nub)
import Data.Time(UTCTime)
import GF.Text.Pretty(render,($$),(<+>),nest)
import PGF(PGF,readProbabilitiesFromFile)
import PGF2(PGF,readProbabilitiesFromFile)
-- | Compiles a number of source files and builds a 'PGF' structure for them.
-- This is a composition of 'link' and 'batchCompile'.

34
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -6,8 +6,8 @@ import GF.Infra.UseIO
import GF.Infra.Option
import GF.Compile.OptimizePGF
import PGF
import PGF.Internal
import PGF2
import PGF2.Internal
import qualified Data.Set as Set
import qualified Data.Map as Map
@@ -20,22 +20,22 @@ import Data.Maybe(fromMaybe)
-- the compiler ----------
--------------------------
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map CId Double -> PGF
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
cf2pgf opts fpath cf probs =
build (let abstr = cf2abstr cf probs
in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
where
name = justModuleName fpath
aname = mkCId (name ++ "Abs")
cname = mkCId name
aname = name ++ "Abs"
cname = name
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map CId Double -> B s AbstrInfo
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
cf2abstr cfg probs = newAbstr aflags acats afuns
where
aflags = [(mkCId "startcat", LStr (fst (cfgStartCat cfg)))]
aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
afuns = [(f', dTyp [hypo Explicit wildCId (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
| rule <- allRules cfg
, let f' = mkRuleName rule]
@@ -53,12 +53,12 @@ cf2abstr cfg probs = newAbstr aflags acats afuns
toLogProb = realToFrac . negate . log
cat2id = mkCId . fst
cat2id = fst
cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
cf2concr opts abstr cfg =
let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
(if flag optOptimizePGF opts then optimizePGF (mkCId (fst (cfgStartCat cfg))) else id)
(if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
(lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
in newConcr abstr [] []
lindefs' linrefs'
@@ -74,7 +74,7 @@ cf2concr opts abstr cfg =
map mkSequence rules)
sequences = Set.toList sequences0
idFun = (wildCId,[Set.findIndex idSeq sequences0])
idFun = ("_",[Set.findIndex idSeq sequences0])
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
cncfuns = reverse cncfuns0
@@ -100,11 +100,11 @@ cf2concr opts abstr cfg =
convertSymbol d (Terminal t) = (d, SymKS t)
mkCncCat fid (cat,n)
| cat == "Int" = (fid, (mkCId cat, fidInt, fidInt, lbls))
| cat == "Float" = (fid, (mkCId cat, fidFloat, fidFloat, lbls))
| cat == "String" = (fid, (mkCId cat, fidString, fidString, lbls))
| cat == "Int" = (fid, (cat, fidInt, fidInt, lbls))
| cat == "Float" = (fid, (cat, fidFloat, fidFloat, lbls))
| cat == "String" = (fid, (cat, fidString, fidString, lbls))
| otherwise = let fid' = fid+n+1
in fid' `seq` (fid', (mkCId cat, fid, fid+n, lbls))
in fid' `seq` (fid', (cat, fid, fid+n, lbls))
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
mkCoercions (fid,cs) c@(cat,ps ) =
@@ -120,7 +120,7 @@ cf2concr opts abstr cfg =
Nothing -> IntMap.insert fid [prod] prods
cat2fid cat p =
case [start | (cat',start,_,_) <- cnccats, mkCId cat == cat'] of
case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
(start:_) -> fid+p
_ -> error "cat2fid"
@@ -133,5 +133,5 @@ cf2concr opts abstr cfg =
mkRuleName rule =
case ruleName rule of
CFObj n _ -> n
_ -> wildCId
_ -> "_"

2
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -1,6 +1,6 @@
module GF.Compile.Compute.Value where
import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
import PGF.Internal(BindType)
import PGF2(BindType)
import GF.Infra.Ident(Ident)
import Text.Show.Functions()
import Data.Ix(Ix)

35
src/compiler/GF/Compile/ExampleBased.hs
View File

@@ -3,11 +3,7 @@ module GF.Compile.ExampleBased (
configureExBased
) where
import PGF
--import PGF.Probabilistic
--import PGF.Morphology
--import GF.Compile.ToAPI
import PGF2
import Data.List
parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
@@ -37,47 +33,38 @@ convertFile conf src file = do
(ex, end) = break (=='"') (tail exend)
in ((unwords (words cat),ex), tail end) -- quotes ignored
pgf = resource_pgf conf
morpho = resource_morpho conf
lang = language conf
convEx (cat,ex) = do
appn "("
let typ = maybe (error "no valid cat") id $ readType cat
ws <- case fst (parse_ pgf lang typ (Just 4) ex) of
ParseFailed _ -> do
let ws = morphoMissing morpho (words ex)
ws <- case parse lang typ ex of
ParseFailed _ _ -> do
appv ("WARNING: cannot parse example " ++ ex)
case ws of
[] -> return ()
_ -> appv (" missing words: " ++ unwords ws)
return ws
TypeError _ ->
return []
ParseIncomplete ->
return []
ParseOk ts ->
case rank ts of
case ts of
(t:tt) -> do
if null tt
then return ()
else appv ("WARNING: ambiguous example " ++ ex)
appn t
mapM_ (appn . (" --- " ++)) tt
appn (printExp conf (fst t))
mapM_ (appn . (" --- " ++) . printExp conf . fst) tt
appn ")"
return []
return ws
rank ts = [printExp conf t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts]
appf = appendFile file
appn s = appf s >> appf "\n"
appv s = appn ("--- " ++ s) >> putStrLn s
data ExConfiguration = ExConf {
resource_pgf :: PGF,
resource_morpho :: Morpho,
resource_pgf :: PGF,
verbose :: Bool,
language :: Language,
printExp :: Tree -> String
language :: Concr,
printExp :: Expr -> String
}
configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr
configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
configureExBased pgf concr pr = ExConf pgf False concr pr

2
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -4,7 +4,7 @@ module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
import GF.Data.Operations
import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import qualified Data.Map as Map
import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe)

25
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -13,8 +13,9 @@ module GF.Compile.GeneratePMCFG
(generatePMCFG, pgfCncCat, addPMCFG, resourceValues
) where
--import PGF.CId
import PGF.Internal as PGF(CId,Symbol(..),fidVar)
import qualified PGF2 as PGF2
import qualified PGF2.Internal as PGF2
import PGF2.Internal(Symbol(..),fidVar)
import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -68,7 +69,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
@@ -92,7 +93,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
seqs1 `seq` stats `seq` return ()
when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
return (seqs1,CncFun mty mlin mprn (Just pmcfg))
where
(ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
@@ -102,11 +103,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (MN identW,cVar) typeStr
@@ -131,7 +132,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
let pmcfg = getPMCFG pmcfgEnv2
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
where
addLindef lins (newCat', newArgs') env0 =
let [newCat] = getFIds newCat'
@@ -157,7 +158,7 @@ convert opts gr cenv loc term ty@(_,val) pargs =
args = map Vr vars
vars = map (\(bt,x,t) -> x) context
pgfCncCat :: SourceGrammar -> CId -> Type -> Int -> (CId,Int,Int,[String])
pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
pgfCncCat gr id lincat index =
let ((_,size),schema) = computeCatRange gr lincat
in ( id
@@ -474,7 +475,7 @@ goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss
----------------------------------------------------------------------
-- SeqSet
type SeqSet = Map.Map Sequence SeqId
type SeqSet = Map.Map [Symbol] SeqId
addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b

2
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -18,7 +18,7 @@ import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
import GF.Infra.Option(optionsPGF)
import PGF.Internal(Literal(..))
import PGF2.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C
import Debug.Trace

40
src/compiler/GF/Compile/OptimizePGF.hs
View File

@@ -1,8 +1,8 @@
{-# LANGUAGE BangPatterns #-}
module GF.Compile.OptimizePGF(optimizePGF) where
import PGF(mkCId)
import PGF.Internal
import PGF2(Cat,Fun)
import PGF2.Internal
import Data.Array.ST
import Data.Array.Unboxed
import qualified Data.Map as Map
@@ -15,19 +15,19 @@ import Control.Monad.ST
type ConcrData = ([(FId,[FunId])], -- ^ Lindefs
[(FId,[FunId])], -- ^ Linrefs
[(FId,[Production])], -- ^ Productions
[(CId,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
[(Fun,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
[[Symbol]], -- ^ Sequences (must be sorted)
[(CId,FId,FId,[String])]) -- ^ Concrete categories
[(Cat,FId,FId,[String])]) -- ^ Concrete categories
optimizePGF :: CId -> ConcrData -> ConcrData
optimizePGF :: Cat -> ConcrData -> ConcrData
optimizePGF startCat = topDownFilter startCat . bottomUpFilter
cidString = mkCId "String"
cidInt = mkCId "Int"
cidFloat = mkCId "Float"
cidVar = mkCId "__gfVar"
topDownFilter :: CId -> ConcrData -> ConcrData
catString = "String"
catInt = "Int"
catFloat = "Float"
catVar = "__gfVar"
topDownFilter :: Cat -> ConcrData -> ConcrData
topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
let env0 = (Map.empty,Map.empty)
(env1,lindefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
@@ -43,10 +43,10 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
(sequences',cncfuns') = env3
in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray sequences',cnccats')
where
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (CId, [SeqId])
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (Fun, [SeqId])
sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
prods_map = IntMap.fromList prods
fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
fid2catMap = IntMap.fromList ((fidVar,catVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
fid <- [start..end]])
fid2cat fid =
@@ -76,17 +76,17 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
-- An element of the array is equal to -1 if the corresponding index
-- is not going to be used in the optimized grammar, or the new index
-- if it will be used
closure :: Map.Map CId [LIndex]
closure :: Map.Map Cat [Int]
closure = runST $ do
set <- initSet
addLitCat cidString set
addLitCat cidInt set
addLitCat cidFloat set
addLitCat cidVar set
addLitCat catString set
addLitCat catInt set
addLitCat catFloat set
addLitCat catVar set
closureSet set starts
doneSet set
where
initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex))
initSet :: ST s (Map.Map Cat (STUArray s Int Int))
initSet =
fmap Map.fromList $ sequence
[fmap ((,) cat) (newArray (0,length lbls-1) (-1))
@@ -109,7 +109,7 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
else closureSet set xs
Nothing -> error "unknown cat"
doneSet :: Map.Map CId (STUArray s LIndex LIndex) -> ST s (Map.Map CId [LIndex])
doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int])
doneSet set =
fmap Map.fromAscList $ mapM done (Map.toAscList set)
where

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

@@ -16,8 +16,8 @@
module GF.Compile.PGFtoHaskell (grammar2haskell) where
import PGF
import PGF.Internal
import PGF2
import PGF2.Internal
import GF.Data.Operations
import GF.Infra.Option
@@ -242,7 +242,7 @@ fInstance gId lexical m (cat,rules) =
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
where
isList = isListCat (cat,rules)
@@ -263,11 +263,11 @@ fInstance gId lexical m (cat,rules) =
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr =
(showCId (abstractName gr),
(abstractName gr,
let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, cs,_) <- fs]) |
[(c, [(f, cs) | (f, cs,_) <- fs]) |
fs@((_, _,c):_) <- fns]
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
)
where
cts = categories gr

184
src/compiler/GF/Compile/PGFtoJSON.hs
View File

@@ -1,156 +1,110 @@
module GF.Compile.PGFtoJSON (pgf2json) where
import PGF (showCId)
import qualified PGF.Internal as M
import PGF.Internal (
Abstr,
CId,
CncCat(..),
CncFun(..),
Concr,
DotPos,
Equation(..),
Literal(..),
PArg(..),
PGF,
Production(..),
Symbol(..),
Type,
absname,
abstract,
cflags,
cnccats,
cncfuns,
concretes,
funs,
productions,
sequences,
totalCats
)
import qualified Text.JSON as JSON
import Text.JSON (JSValue(..))
import qualified Data.Array.IArray as Array
import Data.Map (Map)
import qualified Data.Set as Set
import PGF2
import PGF2.Internal
import Text.JSON
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2json :: PGF -> String
pgf2json pgf =
JSON.encode $ JSON.makeObj
[ ("abstract", json_abstract)
, ("concretes", json_concretes)
]
where
n = showCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = showCId $ M.lookStartCat pgf
json_abstract = abstract2json n start as
json_concretes = JSON.makeObj $ map concrete2json cs
abstract2json :: String -> String -> Abstr -> JSValue
abstract2json name start ds =
JSON.makeObj
[ ("name", mkJSStr name)
, ("startcat", mkJSStr start)
, ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
encode $ makeObj
[ ("abstract", abstract2json pgf)
, ("concretes", makeObj $ map concrete2json
(Map.toList (languages pgf)))
]
absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
abstract2json :: PGF -> JSValue
abstract2json pgf =
makeObj
[ ("name", showJSON (abstractName pgf))
, ("startcat", showJSON (showType [] (startCat pgf)))
, ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
]
absdef2json :: PGF -> Fun -> (String,JSValue)
absdef2json pgf f = (f,sig)
where
(args,cat) = M.catSkeleton typ
sig = JSON.makeObj
[ ("args", JSArray $ map (mkJSStr.showCId) args)
, ("cat", mkJSStr $ showCId cat)
Just (hypos,cat,_) = fmap unType (functionType pgf f)
sig = makeObj
[ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
, ("cat", showJSON cat)
]
lit2json :: Literal -> JSValue
lit2json (LStr s) = mkJSStr s
lit2json (LInt n) = mkJSInt n
lit2json (LFlt d) = JSRational True (toRational d)
lit2json (LStr s) = showJSON s
lit2json (LInt n) = showJSON n
lit2json (LFlt d) = showJSON d
concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (showCId c,obj)
concrete2json :: (ConcName,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (c,obj)
where
obj = JSON.makeObj
[ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
, ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
, ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
, ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
, ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
, ("totalfids", mkJSInt (totalCats cnc))
obj = makeObj
[ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
, ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
, ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
, ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
, ("categories", makeObj $ map cat2json (concrCategories cnc))
, ("totalfids", showJSON (concrTotalCats cnc))
]
cats2json :: (CId, CncCat) -> (String,JSValue)
cats2json (c,CncCat start end _) = (showCId c, ixs)
cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
cat2json (cat,start,end,_) = (cat, ixs)
where
ixs = JSON.makeObj
[ ("start", mkJSInt start)
, ("end", mkJSInt end)
ixs = makeObj
[ ("start", showJSON start)
, ("end", showJSON end)
]
frule2json :: Production -> JSValue
frule2json (PApply fid args) =
JSON.makeObj
[ ("type", mkJSStr "Apply")
, ("fid", mkJSInt fid)
, ("args", JSArray (map farg2json args))
makeObj
[ ("type", showJSON "Apply")
, ("fid", showJSON fid)
, ("args", showJSON (map farg2json args))
]
frule2json (PCoerce arg) =
JSON.makeObj
[ ("type", mkJSStr "Coerce")
, ("arg", mkJSInt arg)
makeObj
[ ("type", showJSON "Coerce")
, ("arg", showJSON arg)
]
farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
JSON.makeObj
[ ("type", mkJSStr "PArg")
, ("hypos", JSArray $ map (mkJSInt . snd) hypos)
, ("fid", mkJSInt fid)
makeObj
[ ("type", showJSON "PArg")
, ("hypos", JSArray $ map (showJSON . snd) hypos)
, ("fid", showJSON fid)
]
ffun2json :: CncFun -> JSValue
ffun2json (CncFun f lins) =
JSON.makeObj
[ ("name", mkJSStr $ showCId f)
, ("lins", JSArray (map mkJSInt (Array.elems lins)))
ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
ffun2json funid (fun,seqids) =
makeObj
[ ("name", showJSON fun)
, ("lins", showJSON seqids)
]
seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
seq2json :: SeqId -> [Symbol] -> JSValue
seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
sym2json :: Symbol -> JSValue
sym2json (SymCat n l) = new "SymCat" [mkJSInt n, mkJSInt l]
sym2json (SymLit n l) = new "SymLit" [mkJSInt n, mkJSInt l]
sym2json (SymVar n l) = new "SymVar" [mkJSInt n, mkJSInt l]
sym2json (SymKS t) = new "SymKS" [mkJSStr t]
sym2json (SymCat n l) = new "SymCat" [showJSON n, showJSON l]
sym2json (SymLit n l) = new "SymLit" [showJSON n, showJSON l]
sym2json (SymVar n l) = new "SymVar" [showJSON n, showJSON l]
sym2json (SymKS t) = new "SymKS" [showJSON t]
sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)]
sym2json SymBIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_BIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [mkJSStr "&+"]
sym2json SymCAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymALL_CAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymBIND = new "SymKS" [showJSON "&+"]
sym2json SymSOFT_BIND = new "SymKS" [showJSON "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [showJSON "&+"]
sym2json SymCAPIT = new "SymKS" [showJSON "&|"]
sym2json SymALL_CAPIT = new "SymKS" [showJSON "&|"]
sym2json SymNE = new "SymNE" []
alt2json :: ([Symbol],[String]) -> JSValue
alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
new :: String -> [JSValue] -> JSValue
new f xs =
JSON.makeObj
[ ("type", mkJSStr f)
, ("args", JSArray xs)
makeObj
[ ("type", showJSON f)
, ("args", showJSON xs)
]
-- | Make JSON value from string
mkJSStr :: String -> JSValue
mkJSStr = JSString . JSON.toJSString
-- | Make JSON value from integer
mkJSInt :: Integral a => a -> JSValue
mkJSInt = JSRational False . toRational

5
src/compiler/GF/Compile/PGFtoJava.hs
View File

@@ -1,6 +1,6 @@
module GF.Compile.PGFtoJava (grammar2java) where
import PGF
import PGF2
import Data.Maybe(maybe)
import Data.List(intercalate)
import GF.Infra.Option
@@ -24,9 +24,8 @@ javaPreamble name =
]
javaMethod gr fun =
" public static Expr "++name++"("++arg_decls++") { return new Expr("++show name++args++"); }"
" public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }"
where
name = showCId fun
arity = maybe 0 getArrity (functionType gr fun)
vars = ['e':show i | i <- [1..arity]]

30
src/compiler/GF/Compile/ToAPI.hs
View File

@@ -2,7 +2,7 @@ module GF.Compile.ToAPI
(stringToAPI,exprToAPI)
where
import PGF
import PGF2
import Data.Maybe
--import System.IO
--import Control.Monad
@@ -46,12 +46,12 @@ exprToFunc :: Expr -> APIfunc
exprToFunc expr =
case unApp expr of
Just (cid,l) ->
case Map.lookup (showCId cid) syntaxFuncs of
case Map.lookup cid syntaxFuncs of
Just sig -> mkAPI True (fst sig,expr)
_ -> case l of
[] -> BasicFunc (showCId cid)
[] -> BasicFunc cid
_ -> let es = map exprToFunc l
in AppFunc (showCId cid) es
in AppFunc cid es
_ -> BasicFunc (showExpr [] expr)
@@ -68,8 +68,8 @@ mkAPI opt (ty,expr) =
where
rephraseSentence ty expr =
case unApp expr of
Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then
let newCat = drop 3 (showCId cid)
Just (cid,es) -> if isPrefixOf "Use" cid then
let newCat = drop 3 cid
afClause = mkAPI True (newCat, es !! 2)
afPol = mkAPI True ("Pol",es !! 1)
lTense = mkAPI True ("Temp", head es)
@@ -97,9 +97,9 @@ mkAPI opt (ty,expr) =
computeAPI :: (String,Expr) -> APIfunc
computeAPI (ty,expr) =
case (unApp expr) of
Just (cid,[]) -> getSimpCat (showCId cid) ty
Just (cid,[]) -> getSimpCat cid ty
Just (cid,es) ->
let p = specFunction (showCId cid) es
let p = specFunction cid es
in if isJust p then fromJust p
else case Map.lookup (show cid) syntaxFuncs of
Nothing -> exprToFunc expr
@@ -146,23 +146,23 @@ optimize expr = optimizeNP expr
optimizeNP expr =
case unApp expr of
Just (cid,es) ->
if showCId cid == "MassNP" then let afs = nounAsCN (head es)
in AppFunc "mkNP" [afs]
else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
ns = nounAsCN (head $ tail es)
in AppFunc "mkNP" (quants ++ [ns])
if cid == "MassNP" then let afs = nounAsCN (head es)
in AppFunc "mkNP" [afs]
else if cid == "DetCN" then let quants = quantAsDet (head es)
ns = nounAsCN (head $ tail es)
in AppFunc "mkNP" (quants ++ [ns])
else mkAPI False ("NP",expr)
_ -> error $ "incorrect expression " ++ (showExpr [] expr)
where
nounAsCN expr =
case unApp expr of
Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es)
Just (cid,es) -> if cid == "UseN" then (mkAPI False) ("N",head es)
else (mkAPI False) ("CN",expr)
_ -> error $ "incorrect expression "++ (showExpr [] expr)
quantAsDet expr =
case unApp expr of
Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
Just (cid,es) -> if cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
else [mkAPI False ("Det",expr)]
_ -> error $ "incorrect expression "++ (showExpr [] expr)

9
src/compiler/GF/Grammar/BNFC.hs
View File

@@ -15,7 +15,6 @@
module GF.Grammar.BNFC(BNFCRule(..), BNFCSymbol, Symbol(..), CFTerm(..), bnfc2cf) where
import GF.Grammar.CFG
import PGF (Token, mkCId)
import Data.List (partition)
type IsList = Bool
@@ -64,12 +63,12 @@ transformRules sepMap (BNFCCoercions c num) = rules ++ [lastRule]
lastRule = Rule (c',[0]) ss rn
where c' = c ++ show num
ss = [Terminal "(", NonTerminal (c,[0]), Terminal ")"]
rn = CFObj (mkCId $ "coercion_" ++ c) []
rn = CFObj ("coercion_" ++ c) []
fRules c n = Rule (c',[0]) ss rn
where c' = if n == 0 then c else c ++ show n
ss = [NonTerminal (c ++ show (n+1),[0])]
rn = CFObj (mkCId $ "coercion_" ++ c') []
rn = CFObj ("coercion_" ++ c') []
transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
transformSymb sepMap s = case s of
@@ -94,7 +93,7 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
then [NonTerminal (c,[0]) | ne]
else [NonTerminal (c,[0]) | ne] ++
[Terminal symb | symb /= "" && ne]
rn = CFObj (mkCId $ "Base" ++ c) []
rn = CFObj ("Base" ++ c) []
ruleCons
| isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
,Rule ("List" ++ c,[1]) smbs1 rn]
@@ -107,4 +106,4 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
smbs = [NonTerminal (c,[0])] ++
[Terminal symb | symb /= ""] ++
[NonTerminal ("List" ++ c,[0])]
rn = CFObj (mkCId $ "Cons" ++ c) []
rn = CFObj ("Cons" ++ c) []

3
src/compiler/GF/Grammar/Binary.hs
View File

@@ -22,8 +22,7 @@ import GF.Infra.Option
import GF.Infra.UseIO(MonadIO(..))
import GF.Grammar.Grammar
import PGF() -- Binary instances
import PGF.Internal(Literal(..),Symbol(..))
import PGF2.Internal(Literal(..),Symbol(..))
-- Please change this every time when the GFO format is changed
gfoVersion = "GF04"

23
src/compiler/GF/Grammar/CFG.hs
View File

@@ -4,10 +4,11 @@
--
-- Context-free grammar representation and manipulation.
----------------------------------------------------------------------
module GF.Grammar.CFG where
module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
import GF.Data.Utilities
import PGF
import PGF2(Fun,Cat)
import PGF2.Internal(Token)
import GF.Data.Relation
import Data.Map (Map)
@@ -20,8 +21,6 @@ import qualified Data.Set as Set
-- * Types
--
type Cat = String
data Symbol c t = NonTerminal c | Terminal t
deriving (Eq, Ord, Show)
@@ -39,12 +38,12 @@ data Grammar c t = Grammar {
deriving (Eq, Ord, Show)
data CFTerm
= CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments
= CFObj Fun [CFTerm] -- ^ an abstract syntax function with arguments
| CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id.
| CFApp CFTerm CFTerm -- ^ Application
| CFRes Int -- ^ The result of the n:th (0-based) non-terminal
| CFVar Int -- ^ A lambda-bound variable
| CFMeta CId -- ^ A metavariable
| CFMeta Fun -- ^ A metavariable
deriving (Eq, Ord, Show)
type CFSymbol = Symbol Cat Token
@@ -232,7 +231,7 @@ uniqueFuns = snd . mapAccumL uniqueFun Set.empty
uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args))
where
fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),
let fun'=mkCId (showCId fun++suffix),
let fun'=fun++suffix,
not (fun' `Set.member` funs)]
-- | Gets all rules in a CFG.
@@ -310,12 +309,12 @@ prProductions prods =
prCFTerm :: CFTerm -> String
prCFTerm = pr 0
where
pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
pr p (CFObj f args) = paren p (f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t)
pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
pr _ (CFRes i) = "$" ++ show i
pr _ (CFVar i) = "x" ++ show i
pr _ (CFMeta c) = "?" ++ showCId c
pr _ (CFMeta c) = "?" ++ c
paren 0 x = x
paren 1 x = "(" ++ x ++ ")"
@@ -323,12 +322,12 @@ prCFTerm = pr 0
-- * CFRule Utilities
--
ruleFun :: Rule c t -> CId
ruleFun :: Rule c t -> Fun
ruleFun (Rule _ _ t) = f t
where f (CFObj n _) = n
f (CFApp _ x) = f x
f (CFAbs _ x) = f x
f _ = mkCId ""
f _ = ""
-- | Check if any of the categories used on the right-hand side
-- are in the given list of categories.
@@ -336,7 +335,7 @@ anyUsedBy :: Eq c => [c] -> Rule c t -> Bool
anyUsedBy cs (Rule _ ss _) = any (`elem` cs) (filterCats ss)
mkCFTerm :: String -> CFTerm
mkCFTerm n = CFObj (mkCId n) []
mkCFTerm n = CFObj n []
ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs

3
src/compiler/GF/Grammar/EBNF.hs
View File

@@ -16,7 +16,6 @@ module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where
import GF.Data.Operations
import GF.Grammar.CFG
import PGF (mkCId)
type EBNF = [ERule]
type ERule = (ECat, ERHS)
@@ -40,7 +39,7 @@ ebnf2cf :: EBNF -> [ParamCFRule]
ebnf2cf ebnf =
[Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
where
mkCFF i (c,_) = CFObj (mkCId ("Mk" ++ c ++ "_" ++ show i)) []
mkCFF i (c,_) = CFObj ("Mk" ++ c ++ "_" ++ show i) []
normEBNF :: EBNF -> [CFJustRule]
normEBNF erules = let

7
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
-- ** PMCFG
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
) where
import GF.Infra.Ident
@@ -73,7 +73,8 @@ import GF.Infra.Location
import GF.Data.Operations
import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
import PGF2(LIndex, BindType(..))
import PGF2.Internal(FId, FunId, SeqId, Symbol)
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -99,7 +100,7 @@ data ModuleInfo = ModInfo {
mopens :: [OpenSpec],
mexdeps :: [ModuleName],
msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence),
mseqs :: Maybe (Array SeqId [Symbol]),
jments :: Map.Map Ident Info
}

5
src/compiler/GF/Grammar/Parser.y
View File

@@ -24,7 +24,6 @@ import GF.Grammar.Lexer
import GF.Compile.Update (buildAnyTree)
import Data.List(intersperse)
import Data.Char(isAlphaNum)
import PGF(mkCId)
}
@@ -624,7 +623,7 @@ ListCFRule
CFRule :: { [BNFCRule] }
CFRule
: Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
: Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
}
| Ident '::=' ListCFRHS ';' { let { cat = showIdent $1;
mkFun cat its =
@@ -637,7 +636,7 @@ CFRule
Terminal c -> filter isAlphaNum c;
NonTerminal (t,_) -> t
}
} in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
} in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
}
| 'coercions' Ident Integer ';' { [BNFCCoercions (showIdent $2) $3]}
| 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }

43
src/compiler/GF/Grammar/Printer.hs
View File

@@ -23,19 +23,16 @@ module GF.Grammar.Printer
, getAbs
) where
import PGF2 as PGF2
import PGF2.Internal as PGF2
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
import qualified Data.Array.IArray as Array
data TermPrintQual
@@ -362,3 +359,39 @@ getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e')
getLet e = ([],e)
ppFunId funid = pp 'F' <> pp funid
ppSeqId seqid = pp 'S' <> pp seqid
ppFId fid
| fid == PGF2.fidString = pp "CString"
| fid == PGF2.fidInt = pp "CInt"
| fid == PGF2.fidFloat = pp "CFloat"
| fid == PGF2.fidVar = pp "CVar"
| fid == PGF2.fidStart = pp "CStart"
| otherwise = pp 'C' <> pp fid
ppMeta :: Int -> Doc
ppMeta n
| n == 0 = pp '?'
| otherwise = pp '?' <> pp n
ppLit (PGF2.LStr s) = pp (show s)
ppLit (PGF2.LInt n) = pp n
ppLit (PGF2.LFlt d) = pp d
ppSeq (seqid,seq) =
ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq)
ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t)
ppSymbol PGF2.SymNE = pp "nonExist"
ppSymbol PGF2.SymBIND = pp "BIND"
ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE"
ppSymbol PGF2.SymCAPIT = pp "CAPIT"
ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

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

@@ -35,7 +35,7 @@ import GF.Infra.Ident
import GF.Infra.GetOpt
import GF.Grammar.Predef
import System.FilePath
import PGF.Internal(Literal(..))
import PGF2.Internal(Literal(..))
import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
@@ -85,12 +85,9 @@ data Phase = Preproc | Convert | Compile | Link
data OutputFormat = FmtPGFPretty
| FmtCanonicalGF
| FmtCanonicalJson
| FmtJavaScript
| FmtJSON
| FmtPython
| FmtHaskell
| FmtJava
| FmtProlog
| FmtBNF
| FmtEBNF
| FmtRegular
@@ -467,12 +464,9 @@ outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
(("js", FmtJavaScript),"JavaScript (whole grammar)"),
(("json", FmtJSON),"JSON (whole grammar)"),
(("python", FmtPython),"Python (whole grammar)"),
(("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("java", FmtJava),"Java (abstract syntax)"),
(("prolog", FmtProlog),"Prolog (whole grammar)"),
(("bnf", FmtBNF),"BNF (context-free grammar)"),
(("ebnf", FmtEBNF),"Extended BNF"),
(("regular", FmtRegular),"* regular grammar"),

44
src/compiler/GF/Interactive.hs
View File

@@ -5,7 +5,7 @@ module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where
import Prelude hiding (putStrLn,print)
import qualified Prelude as P(putStrLn)
import GF.Command.Interpreter(CommandEnv(..),mkCommandEnv,interpretCommandLine)
import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
import GF.Command.Commands(HasPGF(..),pgfCommands)
import GF.Command.CommonCommands(commonCommands,extend)
import GF.Command.SourceCommands
import GF.Command.CommandInfo
@@ -20,7 +20,7 @@ import GF.Infra.SIO
import GF.Infra.Option
import qualified System.Console.Haskeline as Haskeline
import PGF
import PGF2
import Data.Char
import Data.List(isPrefixOf)
@@ -274,17 +274,17 @@ importInEnv opts files =
if flag optRetainResource opts
then do src <- lift $ importSource opts files
pgf <- lift . lazySIO $ importPGF pgf0 -- duplicates some work, better to link src
modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgfEnv pgf)}
modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgf)}
else do pgf1 <- lift $ importPGF pgf0
modify $ \ gfenv->gfenv { retain=False,
pgfenv = (emptyGrammar,pgfEnv pgf1) }
pgfenv = (emptyGrammar,pgf1) }
where
importPGF pgf0 =
do let opts' = addOptions (setOptimization OptCSE False) opts
pgf1 <- importGrammar pgf0 opts' files
if (verbAtLeast opts Normal)
then case pgf1 of
Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf)
Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
Nothing -> done
else done
return pgf1
@@ -298,10 +298,10 @@ tryGetLine = do
prompt env
| retain env = "> "
| otherwise = case multigrammar env of
Just pgf -> showCId (abstractName pgf) ++ "> "
Just pgf -> abstractName pgf ++ "> "
Nothing -> "> "
type CmdEnv = (Grammar,PGFEnv)
type CmdEnv = (Grammar,Maybe PGF)
data GFEnv = GFEnv {
startOpts :: Options,
@@ -313,10 +313,10 @@ data GFEnv = GFEnv {
emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv []
emptyCmdEnv = (emptyGrammar,pgfEnv Nothing)
emptyCmdEnv = (emptyGrammar,Nothing)
emptyCommandEnv = mkCommandEnv allCommands
multigrammar = pgf . snd . pgfenv
multigrammar = snd . pgfenv
allCommands =
extend pgfCommands (helpCommand allCommands:moreCommands)
@@ -324,7 +324,7 @@ allCommands =
`Map.union` commonCommands
instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
instance HasPGFEnv ShellM where getPGFEnv = gets (snd . pgfenv)
instance HasPGF ShellM where getPGF = gets (snd . pgfenv)
wordCompletion gfenv (left,right) = do
case wc_type (reverse left) of
@@ -332,17 +332,13 @@ wordCompletion gfenv (left,right) = do
-> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
CmplStr (Just (Command _ opts _)) s0
-> case multigrammar gfenv of
Just pgf -> let optLang opts = case valStrOpts "lang" "" opts of
"" -> case languages pgf of
[] -> Nothing
(lang:_) -> Just lang
lang -> let cla = mkCId lang in
if elem cla (languages pgf)
then Just cla
else let cla = mkCId (showCId (abstractName pgf) ++ lang)
in if elem cla (languages pgf)
then Just cla
else Nothing
Just pgf -> let langs = languages pgf
optLang opts = case valStrOpts "lang" "" opts of
"" -> case Map.minView langs of
Nothing -> Nothing
Just (concr,_) -> Just concr
lang -> mplus (Map.lookup lang langs)
(Map.lookup (abstractName pgf ++ lang) langs)
optType opts = let readOpt str = case readType str of
Just ty -> case checkType pgf ty of
Left _ -> Nothing
@@ -353,8 +349,8 @@ wordCompletion gfenv (left,right) = do
s = reverse rs
prefix = reverse rprefix
in case (optLang opts, optType opts) of
(Just lang,Just cat) -> let (_,_,compls) = complete pgf lang cat s prefix
in ret (length prefix) (map Haskeline.simpleCompletion (Map.keys compls))
(Just lang,Just cat) -> let compls = [t | (t,_,_,_) <- complete lang cat s prefix]
in ret (length prefix) (map Haskeline.simpleCompletion compls)
_ -> ret 0 []
Nothing -> ret 0 []
CmplOpt (Just (Command n _ _)) pref
@@ -368,7 +364,7 @@ wordCompletion gfenv (left,right) = do
-> Haskeline.completeFilename (left,right)
CmplIdent _ pref
-> case multigrammar gfenv of
Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | cid <- functions pgf, let name = showCId cid, isPrefixOf pref name]
Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
Nothing -> ret (length pref) []
_ -> ret 0 []
where

445
src/compiler/GF/Interactive2.hs
View File

@@ -1,445 +0,0 @@
{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
-- | GF interactive mode (with the C run-time system)
module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where
import Prelude hiding (putStrLn,print)
import qualified Prelude as P(putStrLn)
import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine)
import GF.Command.Commands2(PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands)
import GF.Command.CommonCommands
import GF.Command.CommandInfo
import GF.Command.Help(helpCommand)
import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand)
import GF.Data.Operations (Err(..),done)
import GF.Data.Utilities(whenM,repeatM)
import GF.Infra.UseIO(ioErrorText,putStrLnE)
import GF.Infra.SIO
import GF.Infra.Option
import qualified System.Console.Haskeline as Haskeline
--import GF.Text.Coding(decodeUnicode,encodeUnicode)
--import GF.Compile.Coding(codeTerm)
import qualified PGF2 as C
import qualified PGF as H
import Data.Char
import Data.List(isPrefixOf)
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
--import System.IO(utf8)
--import System.CPUTime(getCPUTime)
import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
import System.FilePath(takeExtensions)
import Control.Exception(SomeException,fromException,try)
--import Control.Monad
import Control.Monad.State hiding (void)
import qualified GF.System.Signal as IO(runInterruptibly)
{-
#ifdef SERVER_MODE
import GF.Server(server)
#endif
-}
import GF.Command.Messages(welcome)
-- | Run the GF Shell in quiet mode (@gf -run@).
mainRunGFI :: Options -> [FilePath] -> IO ()
mainRunGFI opts files = shell (beQuiet opts) files
beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
-- | Run the interactive GF Shell
mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do
P.putStrLn welcome
P.putStrLn "This shell uses the C run-time system. See help for available commands."
shell opts files
shell opts files = flip evalStateT (emptyGFEnv opts) $
do mapStateT runSIO $ importInEnv opts files
loop
{-
#ifdef SERVER_MODE
-- | Run the GF Server (@gf -server@).
-- The 'Int' argument is the port number for the HTTP service.
mainServerGFI opts0 port files =
server jobs port root (execute1 opts)
=<< runSIO (importInEnv (emptyGFEnv opts) opts files)
where
root = flag optDocumentRoot opts
opts = beQuiet opts0
jobs = join (flag optJobs opts)
#else
mainServerGFI opts port files =
error "GF has not been compiled with server mode support"
#endif
-}
-- | Read end execute commands until it is time to quit
loop :: StateT GFEnv IO ()
loop = repeatM readAndExecute1
-- | Read and execute one command, returning 'True' to continue execution,
-- | 'False' when it is time to quit
readAndExecute1 :: StateT GFEnv IO Bool
readAndExecute1 = mapStateT runSIO . execute1 =<< readCommand
-- | Read a command
readCommand :: StateT GFEnv IO String
readCommand =
do opts <- gets startOpts
case flag optMode opts of
ModeRun -> lift tryGetLine
_ -> lift . fetchCommand =<< get
timeIt act =
do t1 <- liftSIO $ getCPUTime
a <- act
t2 <- liftSIO $ getCPUTime
return (t2-t1,a)
-- | Optionally show how much CPU time was used to run an IO action
optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
optionallyShowCPUTime opts act
| not (verbAtLeast opts Normal) = act
| otherwise = do (dt,r) <- timeIt act
liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
return r
type ShellM = StateT GFEnv SIO
-- | Execute a given command line, returning 'True' to continue execution,
-- | 'False' when it is time to quit
execute1 :: String -> ShellM Bool
execute1 s0 =
do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
execute1' s0
-- | Execute a given command line, without adding it to the history
execute1' s0 =
do opts <- gets startOpts
interruptible $ optionallyShowCPUTime opts $
case pwords s0 of
-- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
-- special commands
"q" :_ -> quit
"!" :ws -> system_command ws
"eh":ws -> execute_history ws
"i" :ws -> do import_ ws; continue
-- other special commands, working on GFEnv
"dc":ws -> define_command ws
"dt":ws -> define_tree ws
-- ordinary commands
_ -> do env <- gets commandenv
interpretCommandLine env s0
continue
where
continue,stop :: ShellM Bool
continue = return True
stop = return False
interruptible :: ShellM Bool -> ShellM Bool
interruptible act =
do gfenv <- get
mapStateT (
either (\e -> printException e >> return (True,gfenv)) return
<=< runInterruptibly) act
-- Special commands:
quit = do opts <- gets startOpts
when (verbAtLeast opts Normal) $ putStrLnE "See you."
stop
system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
{-"eh":w:_ -> do
cs <- readFile w >>= return . map words . lines
gfenv' <- foldM (flip (process False benv)) gfenv cs
loopNewCPU gfenv' -}
execute_history [w] =
do execute . lines =<< lift (restricted (readFile w))
continue
where
execute :: [String] -> ShellM ()
execute [] = done
execute (line:lines) = whenM (execute1' line) (execute lines)
execute_history _ =
do putStrLnE "eh command not parsed"
continue
define_command (f:ws) =
case readCommandLine (unwords ws) of
Just comm ->
do modify $
\ gfenv ->
let env = commandenv gfenv
in gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
continue
_ -> dc_not_parsed
define_command _ = dc_not_parsed
dc_not_parsed = putStrLnE "command definition not parsed" >> continue
define_tree (f:ws) =
case H.readExpr (unwords ws) of
Just exp ->
do modify $
\ gfenv ->
let env = commandenv gfenv
in gfenv { commandenv = env {
expmacros = Map.insert f exp (expmacros env) } }
continue
_ -> dt_not_parsed
define_tree _ = dt_not_parsed
dt_not_parsed = putStrLnE "value definition not parsed" >> continue
pwords s = case words s of
w:ws -> getCommandOp w :ws
ws -> ws
import_ args =
do case parseOptions args of
Ok (opts',files) -> do
opts <- gets startOpts
curr_dir <- lift getCurrentDirectory
lib_dir <- lift $ getLibraryDirectory (addOptions opts opts')
importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
Bad err ->
do putStrLnE $ "Command parse error: " ++ err
-- | Commands that work on 'GFEnv'
moreCommands = [
("e", emptyCommandInfo {
longname = "empty",
synopsis = "empty the environment (except the command history)",
exec = \ _ _ ->
do modify $ \ gfenv -> (emptyGFEnv (startOpts gfenv))
{ history=history gfenv }
return void
}),
("ph", emptyCommandInfo {
longname = "print_history",
synopsis = "print command history",
explanation = unlines [
"Prints the commands issued during the GF session.",
"The result is readable by the eh command.",
"The result can be used as a script when starting GF."
],
examples = [
mkEx "ph | wf -file=foo.gfs -- save the history into a file"
],
exec = \ _ _ ->
fmap (fromString . unlines . reverse . drop 1 . history) get
}),
("r", emptyCommandInfo {
longname = "reload",
synopsis = "repeat the latest import command",
exec = \ _ _ ->
do gfenv0 <- get
let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
case imports of
(s,ws):_ -> do
putStrLnE $ "repeating latest import: " ++ s
import_ ws
_ -> do
putStrLnE $ "no import in history"
return void
})
]
printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
fetchCommand :: GFEnv -> IO String
fetchCommand gfenv = do
path <- getAppUserDataDirectory "gf_history"
let settings =
Haskeline.Settings {
Haskeline.complete = wordCompletion gfenv,
Haskeline.historyFile = Just path,
Haskeline.autoAddHistory = True
}
res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt gfenv))
case res of
Left _ -> return ""
Right Nothing -> return "q"
Right (Just s) -> return s
importInEnv :: Options -> [FilePath] -> ShellM ()
importInEnv opts files =
case files of
_ | flag optRetainResource opts ->
putStrLnE "Flag -retain is not supported in this shell"
[file] | takeExtensions file == ".pgf" -> importPGF file
[] -> done
_ -> do putStrLnE "Can only import one .pgf file"
where
importPGF file =
do gfenv <- get
case multigrammar gfenv of
Just _ -> putStrLnE "Discarding previous grammar"
_ -> done
pgf1 <- lift $ readPGF2 file
let gfenv' = gfenv { pgfenv = pgfEnv pgf1 }
when (verbAtLeast opts Normal) $
let langs = Map.keys . concretes $ gfenv'
in putStrLnE . unwords $ "\nLanguages:":langs
put gfenv'
tryGetLine = do
res <- try getLine
case res of
Left (e :: SomeException) -> return "q"
Right l -> return l
prompt env = abs ++ "> "
where
abs = maybe "" C.abstractName (multigrammar env)
data GFEnv = GFEnv {
startOpts :: Options,
--grammar :: (), -- gfo grammar -retain
--retain :: (), -- grammar was imported with -retain flag
pgfenv :: PGFEnv,
commandenv :: CommandEnv ShellM,
history :: [String]
}
emptyGFEnv opts = GFEnv opts {-() ()-} emptyPGFEnv emptyCommandEnv []
emptyCommandEnv = mkCommandEnv allCommands
multigrammar = pgf . pgfenv
concretes = concs . pgfenv
allCommands =
extend pgfCommands (helpCommand allCommands:moreCommands)
`Map.union` commonCommands
instance HasPGFEnv ShellM where getPGFEnv = gets pgfenv
-- ** Completion
wordCompletion gfenv (left,right) = do
case wc_type (reverse left) of
CmplCmd pref
-> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
{-
CmplStr (Just (Command _ opts _)) s0
-> do mb_state0 <- try (evaluate (H.initState pgf (optLang opts) (optType opts)))
case mb_state0 of
Right state0 -> let (rprefix,rs) = break isSpace (reverse s0)
s = reverse rs
prefix = reverse rprefix
ws = words s
in case loop state0 ws of
Nothing -> ret 0 []
Just state -> let compls = H.getCompletions state prefix
in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
Left (_ :: SomeException) -> ret 0 []
-}
CmplOpt (Just (Command n _ _)) pref
-> case Map.lookup n (commands cmdEnv) of
Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg]
opt_compls = [Haskeline.Completion ('-':opt) ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt]
ret (length pref+1)
(flg_compls++opt_compls)
Nothing -> ret (length pref) []
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
-> Haskeline.completeFilename (left,right)
CmplIdent _ pref
-> case mb_pgf of
Just pgf -> ret (length pref)
[Haskeline.simpleCompletion name
| name <- C.functions pgf,
isPrefixOf pref name]
_ -> ret (length pref) []
_ -> ret 0 []
where
mb_pgf = multigrammar gfenv
cmdEnv = commandenv gfenv
{-
optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts
optType opts =
let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts
in case H.readType str of
Just ty -> ty
Nothing -> error ("Can't parse '"++str++"' as type")
loop ps [] = Just ps
loop ps (t:ts) = case H.nextState ps (H.simpleParseInput t) of
Left es -> Nothing
Right ps -> loop ps ts
-}
ret len xs = return (drop len left,xs)
data CompletionType
= CmplCmd Ident
| CmplStr (Maybe Command) String
| CmplOpt (Maybe Command) Ident
| CmplIdent (Maybe Command) Ident
deriving Show
wc_type :: String -> CompletionType
wc_type = cmd_name
where
cmd_name cs =
let cs1 = dropWhile isSpace cs
in go cs1 cs1
where
go x [] = CmplCmd x
go x (c:cs)
| isIdent c = go x cs
| otherwise = cmd x cs
cmd x [] = ret CmplIdent x "" 0
cmd _ ('|':cs) = cmd_name cs
cmd _ (';':cs) = cmd_name cs
cmd x ('"':cs) = str x cs cs
cmd x ('-':cs) = option x cs cs
cmd x (c :cs)
| isIdent c = ident x (c:cs) cs
| otherwise = cmd x cs
option x y [] = ret CmplOpt x y 1
option x y ('=':cs) = optValue x y cs
option x y (c :cs)
| isIdent c = option x y cs
| otherwise = cmd x cs
optValue x y ('"':cs) = str x y cs
optValue x y cs = cmd x cs
ident x y [] = ret CmplIdent x y 0
ident x y (c:cs)
| isIdent c = ident x y cs
| otherwise = cmd x cs
str x y [] = ret CmplStr x y 1
str x y ('\"':cs) = cmd x cs
str x y ('\\':c:cs) = str x y cs
str x y (c:cs) = str x y cs
ret f x y d = f cmd y
where
x1 = take (length x - length y - d) x
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
[x] -> Just x
_ -> Nothing
isIdent c = c == '_' || c == '\'' || isAlphaNum c

22
src/compiler/GF/Quiz.hs
View File

@@ -18,13 +18,8 @@ module GF.Quiz (
morphologyList
) where
import PGF
--import PGF.Linearize
import PGF2
import GF.Data.Operations
--import GF.Infra.UseIO
--import GF.Infra.Option
--import PGF.Probabilistic
import System.Random
import Data.List (nub)
@@ -38,7 +33,7 @@ mkQuiz msg tts = do
teachDialogue qas msg
translationList ::
Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
Maybe Expr -> PGF -> Concr -> Concr -> Type -> Int -> IO [(String,[String])]
translationList mex pgf ig og typ number = do
gen <- newStdGen
let ts = take number $ case mex of
@@ -46,19 +41,22 @@ translationList mex pgf ig og typ number = do
Nothing -> generateRandom gen pgf typ
return $ map mkOne $ ts
where
mkOne t = (norml (linearize pgf ig t),
mkOne t = (norml (linearize ig t),
map norml (concatMap lins (homonyms t)))
homonyms = parse pgf ig typ . linearize pgf ig
lins = nub . concatMap (map snd) . tabularLinearizes pgf og
homonyms t =
case (parse ig typ . linearize ig) t of
ParseOk res -> map fst res
_ -> []
lins = nub . concatMap (map snd) . tabularLinearizeAll og
morphologyList ::
Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])]
Maybe Expr -> PGF -> Concr -> Type -> Int -> IO [(String,[String])]
morphologyList mex pgf ig typ number = do
gen <- newStdGen
let ts = take (max 1 number) $ case mex of
Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom gen pgf typ
let ss = map (tabularLinearizes pgf ig) ts
let ss = map (tabularLinearizeAll ig) ts
let size = length (head (head ss))
let forms = take number $ randomRs (0,size-1) gen
return [(snd (head pws0) +++ fst (pws0 !! i), ws) |

2
src/compiler/GF/Server.hs
View File

@@ -42,7 +42,6 @@ import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
import GF.Infra.SIO(captureSIO)
import GF.Data.Utilities(apSnd,mapSnd)
import qualified PGFService as PS
import qualified ExampleService as ES
import Data.Version(showVersion)
import Paths_gf(getDataDir,version)
import GF.Infra.BuildInfo (buildInfo)
@@ -170,7 +169,6 @@ handle logLn documentroot state0 cache execute1 stateVar
(_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path
wrapCGI $ PS.cgiMain' cache path
(dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs)
(dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (PS.pgfCache cache)
_ -> serveStaticFile rpath path
where path = translatePath rpath
_ -> return $ resp400 upath

1
src/compiler/GF/Speech/CFGToFA.hs
View File

@@ -14,7 +14,6 @@ import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import PGF.Internal
import GF.Data.Utilities
import GF.Grammar.CFG
--import GF.Speech.PGFToCFG

6
src/compiler/GF/Speech/GSL.hs
View File

@@ -8,13 +8,11 @@
module GF.Speech.GSL (gslPrinter) where
--import GF.Data.Utilities
import GF.Grammar.CFG
import GF.Speech.SRG
import GF.Speech.RegExp
import GF.Infra.Option
--import GF.Infra.Ident
import PGF
import PGF2
import Data.Char (toUpper,toLower)
import Data.List (partition)
@@ -23,7 +21,7 @@ import GF.Text.Pretty
width :: Int
width = 75
gslPrinter :: Options -> PGF -> CId -> String
gslPrinter :: Options -> PGF -> Concr -> String
gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width }

6
src/compiler/GF/Speech/JSGF.hs
View File

@@ -18,7 +18,7 @@ import GF.Grammar.CFG
import GF.Speech.RegExp
import GF.Speech.SISR
import GF.Speech.SRG
import PGF
import PGF2
import Data.Char
import Data.List
@@ -30,8 +30,8 @@ width :: Int
width = 75
jsgfPrinter :: Options
-> PGF
-> CId -> String
-> PGF
-> Concr -> String
jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where st = style { lineLength = width }
sisr = flag optSISR opts

6
src/compiler/GF/Speech/PrRegExp.hs
View File

@@ -11,12 +11,12 @@ import GF.Grammar.CFG
import GF.Speech.CFGToFA
import GF.Speech.PGFToCFG
import GF.Speech.RegExp
import PGF
import PGF2
regexpPrinter :: PGF -> CId -> String
regexpPrinter :: PGF -> Concr -> String
regexpPrinter pgf cnc = (++"\n") $ prRE id $ dfa2re $ cfgToFA $ pgfToCFG pgf cnc
multiRegexpPrinter :: PGF -> CId -> String
multiRegexpPrinter :: PGF -> Concr -> String
multiRegexpPrinter pgf cnc = prREs $ mfa2res $ cfgToMFA $ pgfToCFG pgf cnc
prREs :: [(String,RE CFSymbol)] -> String

8
src/compiler/GF/Speech/SISR.hs
View File

@@ -10,13 +10,9 @@ module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR,
import Data.List
--import GF.Data.Utilities
--import GF.Infra.Ident
import GF.Infra.Option (SISRFormat(..))
import GF.Grammar.CFG
import GF.Speech.SRG (SRGNT)
import PGF(showCId)
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS
@@ -50,12 +46,12 @@ catSISR t (c,i) fmt
profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term]
where
f (CFObj n ts) = tree (showCId n) (map f ts)
f (CFObj n ts) = tree n (map f ts)
f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)]
f (CFApp x y) = JS.ECall (f x) [f y]
f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i))
f (CFVar v) = JS.EVar (var v)
f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (showCId typ))]
f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr typ)]
fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$")
fmtOut SISR_1_0 = JS.EVar (JS.Ident "out")

15
src/compiler/GF/Speech/SLF.hs
View File

@@ -16,17 +16,14 @@ module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter,
import GF.Data.Utilities
import GF.Grammar.CFG
import GF.Speech.FiniteState
--import GF.Speech.CFG
import GF.Speech.CFGToFA
import GF.Speech.PGFToCFG
import qualified GF.Data.Graphviz as Dot
import PGF
--import PGF.CId
import PGF2
import Control.Monad
import qualified Control.Monad.State as STM
import Data.Char (toUpper)
--import Data.List
import Data.Maybe
data SLFs = SLFs [(String,SLF)] SLF
@@ -43,7 +40,7 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
type SLF_FA = FA State (Maybe CFSymbol) ()
mkFAs :: PGF -> CId -> (SLF_FA, [(String,SLF_FA)])
mkFAs :: PGF -> Concr -> (SLF_FA, [(String,SLF_FA)])
mkFAs pgf cnc = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
where MFA start subs = {- renameSubs $ -} cfgToMFA $ pgfToCFG pgf cnc
main = let (fa,s,f) = newFA_ in newTransition s f (NonTerminal start) fa
@@ -64,7 +61,7 @@ renameSubs (MFA start subs) = MFA (newName start) subs'
-- * SLF graphviz printing (without sub-networks)
--
slfGraphvizPrinter :: PGF -> CId -> String
slfGraphvizPrinter :: PGF -> Concr -> String
slfGraphvizPrinter pgf cnc
= prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
where
@@ -74,7 +71,7 @@ slfGraphvizPrinter pgf cnc
-- * SLF graphviz printing (with sub-networks)
--
slfSubGraphvizPrinter :: PGF -> CId -> String
slfSubGraphvizPrinter :: PGF -> Concr -> String
slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g
where (main, subs) = mkFAs pgf cnc
g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..]
@@ -100,7 +97,7 @@ gvSLFFA n fa =
-- * SLF printing (without sub-networks)
--
slfPrinter :: PGF -> CId -> String
slfPrinter :: PGF -> Concr -> String
slfPrinter pgf cnc
= prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
@@ -109,7 +106,7 @@ slfPrinter pgf cnc
--
-- | Make a network with subnetworks in SLF
slfSubPrinter :: PGF -> CId -> String
slfSubPrinter :: PGF -> Concr -> String
slfSubPrinter pgf cnc = prSLFs slfs
where
(main,subs) = mkFAs pgf cnc

28
src/compiler/GF/Speech/SRG.hs
View File

@@ -17,21 +17,15 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
, lookupFM_
) where
--import GF.Data.Operations
import PGF2
import GF.Data.Utilities
--import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.CFG
import GF.Speech.PGFToCFG
--import GF.Data.Relation
--import GF.Speech.FiniteState
import GF.Speech.RegExp
import GF.Speech.CFGToFA
--import GF.Infra.Option
import PGF
import Data.List
--import Data.Maybe (fromMaybe, maybeToList)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -62,16 +56,16 @@ type SRGSymbol = Symbol SRGNT Token
-- | An SRG non-terminal. Category name and its number in the profile.
type SRGNT = (Cat, Int)
ebnfPrinter :: Options -> PGF -> CId -> String
ebnfPrinter :: Options -> PGF -> Concr -> String
ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
-- | Create a compact filtered non-left-recursive SRG.
makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
makeNonLeftRecursiveSRG :: Options -> PGF -> Concr -> SRG
makeNonLeftRecursiveSRG opts = makeSRG opts'
where
opts' = setDefaultCFGTransform opts CFGNoLR True
makeSRG :: Options -> PGF -> CId -> SRG
makeSRG :: Options -> PGF -> Concr -> SRG
makeSRG opts = mkSRG cfgToSRG preprocess
where
cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
@@ -97,7 +91,7 @@ stats g = "Categories: " ++ show (countCats g)
-}
makeNonRecursiveSRG :: Options
-> PGF
-> CId -- ^ Concrete syntax name.
-> Concr
-> SRG
makeNonRecursiveSRG opts = mkSRG cfgToSRG id
where
@@ -105,17 +99,17 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
where
MFA _ dfas = cfgToMFA cfg
dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re
dummyCFTerm = CFMeta (mkCId "dummy")
dummyCFTerm = CFMeta "dummy"
dummySRGNT = mapSymbol (\c -> (c,0)) id
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> Concr -> SRG
mkSRG mkRules preprocess pgf cnc =
SRG { srgName = showCId cnc,
srgStartCat = cfgStartCat cfg,
SRG { srgName = concreteName cnc,
srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg,
srgLanguage = languageCode pgf cnc,
srgLanguage = languageCode cnc,
srgRules = mkRules cfg }
where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
where cfg = renameCats (concreteName cnc) $ preprocess $ pgfToCFG pgf cnc
-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
-- to C_N where N is an integer.

8
src/compiler/GF/Speech/SRGS_ABNF.hs
View File

@@ -25,23 +25,21 @@ import GF.Grammar.CFG
import GF.Speech.SISR as SISR
import GF.Speech.SRG
import GF.Speech.RegExp
import PGF (PGF, CId)
import PGF2 (PGF,Concr)
--import Data.Char
import Data.List
import Data.Maybe
import GF.Text.Pretty
--import Debug.Trace
width :: Int
width = 75
srgsAbnfPrinter :: Options
-> PGF -> CId -> String
-> PGF -> Concr -> String
srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where sisr = flag optSISR opts
srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsAbnfNonRecursivePrinter :: Options -> PGF -> Concr -> String
srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc
showDoc = renderStyle (style { lineLength = width })

6
src/compiler/GF/Speech/SRGS_XML.hs
View File

@@ -13,7 +13,7 @@ import GF.Grammar.CFG
import GF.Speech.RegExp
import GF.Speech.SISR as SISR
import GF.Speech.SRG
import PGF (PGF, CId, Token)
import PGF2 (PGF, Concr)
--import Control.Monad
--import Data.Char (toUpper,toLower)
@@ -22,11 +22,11 @@ import Data.Maybe
--import qualified Data.Map as Map
srgsXmlPrinter :: Options
-> PGF -> CId -> String
-> PGF -> Concr -> String
srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc
where sisr = flag optSISR opts
srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
srgsXmlNonRecursivePrinter :: Options -> PGF -> Concr -> String
srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc

72
src/compiler/GF/Speech/VoiceXML.hs
View File

@@ -6,14 +6,8 @@
-----------------------------------------------------------------------------
module GF.Speech.VoiceXML (grammar2vxml) where
--import GF.Data.Operations
--import GF.Data.Str (sstrV)
--import GF.Data.Utilities
import GF.Data.XML
--import GF.Infra.Ident
import PGF
--import Control.Monad (liftM)
import PGF2
import Data.List (intersperse) -- isPrefixOf, find
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
@@ -21,19 +15,19 @@ import Data.Maybe (fromMaybe)
--import Debug.Trace
-- | the main function
grammar2vxml :: PGF -> CId -> String
grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
grammar2vxml :: PGF -> Concr -> String
grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name mb_language start skel qs) ""
where skel = pgfSkeleton pgf
name = showCId cnc
qs = catQuestions pgf cnc (map fst skel)
language = languageCode pgf cnc
name = concreteName cnc
qs = catQuestions cnc (map fst skel)
mb_language = languageCode cnc
(_,start,_) = unType (startCat pgf)
--
-- * VSkeleton: a simple description of the abstract syntax.
--
type Skeleton = [(CId, [(CId, [CId])])]
type Skeleton = [(Cat, [(Fun, [Cat])])]
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) | f <- functionsByCat pgf c, Just (hypos,_,_) <- [fmap unType (functionType pgf f)]])
@@ -43,37 +37,23 @@ pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty])
-- * Questions to ask
--
type CatQuestions = [(CId,String)]
type CatQuestions = [(Cat,String)]
catQuestions :: PGF -> CId -> [CId] -> CatQuestions
catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats]
catQuestions :: Concr -> [Cat] -> CatQuestions
catQuestions cnc cats = [(c,catQuestion cnc c) | c <- cats]
catQuestion :: PGF -> CId -> CId -> String
catQuestion pgf cnc cat = showPrintName pgf cnc cat
catQuestion :: Concr -> Cat -> String
catQuestion cnc cat = fromMaybe cat (printName cnc cat)
{-
lin :: StateGrammar -> String -> Err String
lin gr fun = do
tree <- string2treeErr gr fun
let ls = map unt $ linTree2strings noMark g c tree
case ls of
[] -> fail $ "No linearization of " ++ fun
l:_ -> return l
where c = cncId gr
g = stateGrammarST gr
unt = formatAsText
-}
getCatQuestion :: CId -> CatQuestions -> String
getCatQuestion :: Cat -> CatQuestions -> String
getCatQuestion c qs =
fromMaybe (error "No question for category " ++ showCId c) (lookup c qs)
fromMaybe (error "No question for category " ++ c) (lookup c qs)
--
-- * Generate VoiceXML
--
skel2vxml :: String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML
skel2vxml :: String -> Maybe String -> Cat -> Skeleton -> CatQuestions -> XML
skel2vxml name language start skel qs =
vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel)
where
@@ -85,12 +65,12 @@ grammarURI :: String -> String
grammarURI name = name ++ ".grxml"
catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> [XML]
catForms gr qs cat fs =
comments [showCId cat ++ " category."]
comments [cat ++ " category."]
++ [cat2form gr qs cat fs]
cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
cat2form :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> XML
cat2form gr qs cat fs =
form (catFormId cat) $
[var "old" Nothing,
@@ -103,22 +83,22 @@ cat2form gr qs cat fs =
++ concatMap (uncurry (fun2sub gr cat)) fs
++ [block [return_ ["term"]{-]-}]]
fun2sub :: String -> CId -> CId -> [CId] -> [XML]
fun2sub :: String -> Cat -> Fun -> [Cat] -> [XML]
fun2sub gr cat fun args =
comments [showCId fun ++ " : ("
++ concat (intersperse ", " (map showCId args))
++ ") " ++ showCId cat] ++ ss
comments [fun ++ " : ("
++ concat (intersperse ", " args)
++ ") " ++ cat] ++ ss
where
ss = zipWith mkSub [0..] args
mkSub n t = subdialog s [("src","#"++catFormId t),
("cond","term.name == "++string (showCId fun))]
("cond","term.name == "++string fun)]
[param "old" v,
filled [] [assign v (s++".term")]]
where s = showCId fun ++ "_" ++ show n
where s = fun ++ "_" ++ show n
v = "term.args["++show n++"]"
catFormId :: CId -> String
catFormId c = showCId c ++ "_cat"
catFormId :: Cat -> String
catFormId c = c ++ "_cat"
--

1
src/compiler/GF/Text/Lexing.hs
View File

@@ -15,7 +15,6 @@ stringOp good name = case name of
"lexgreek" -> Just $ appLexer lexAGreek
"lexgreek2" -> Just $ appLexer lexAGreek2
"words" -> Just $ appLexer words
"bind" -> Just $ appUnlexer (unwords . bindTok)
"unchars" -> Just $ appUnlexer concat
"unlextext" -> Just $ appUnlexer (unlexText . unquote . bindTok)
"unlexcode" -> Just $ appUnlexer unlexCode

2
src/compiler/SimpleEditor/Convert.hs
View File

@@ -17,7 +17,7 @@ import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
import GF.Grammar.Parser(runP,pModDef)
import GF.Grammar.Lexer(Posn(..))
import GF.Data.ErrM
import PGF.Internal(Literal(LStr))
import PGF2.Internal(Literal(LStr))
import SimpleEditor.Syntax as S
import SimpleEditor.JSON

4
src/runtime/c/pgf/pgf.c
View File

@@ -227,7 +227,7 @@ pgf_language_code(PgfConcr* concr)
gu_seq_binsearch(concr->cflags, pgf_flag_order, PgfFlag, "language");
if (flag == NULL)
return "";
return NULL;
GuVariantInfo i = gu_variant_open(flag->value);
switch (i.tag) {
@@ -237,7 +237,7 @@ pgf_language_code(PgfConcr* concr)
}
}
return "";
return NULL;
}
PGF_API void

44
src/runtime/haskell-bind/PGF2.hsc
View File

@@ -57,19 +57,24 @@ module PGF2 (-- * PGF
linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,
FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString,
printName,
alignWords, gizaAlignment,
alignWords,
-- ** Parsing
ParseOutput(..), parse, parseWithHeuristics, complete,
-- ** Sentence Lookup
lookupSentence,
-- ** Generation
generateAll,
generateAll, generateAllFrom,
generateRandom, generateRandomFrom,
-- ** Morphological Analysis
MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon,
-- ** Visualizations
GraphvizOptions(..), graphvizDefaults,
graphvizAbstractTree, graphvizParseTree,
Labels, getDepLabels,
graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
graphvizWordAlignment,
@@ -77,13 +82,17 @@ module PGF2 (-- * PGF
PGFError(..),
-- * Grammar specific callbacks
LiteralCallback,literalCallbacks
LiteralCallback,literalCallbacks,
-- * Auxiliaries
readProbabilitiesFromFile
) where
import Prelude hiding (fromEnum)
import Control.Exception(Exception,throwIO)
import Control.Monad(forM_)
import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
import System.Random
import Text.PrettyPrint
import PGF2.Expr
import PGF2.Type
@@ -171,9 +180,12 @@ languages p = langs p
concreteName :: Concr -> ConcName
concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c))
languageCode :: Concr -> String
languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c))
languageCode :: Concr -> Maybe String
languageCode c = unsafePerformIO $ do
c_code <- pgf_language_code (concr c)
if c_code == nullPtr
then return Nothing
else fmap Just (peekUtf8CString c_code)
-- | Generates an exhaustive possibly infinite list of
-- all abstract syntax expressions of the given type.
@@ -189,6 +201,15 @@ generateAll p (Type ctype _) =
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
fromPgfExprEnum enum genFPl (touchPGF p >> touchForeignPtr exprFPl)
generateAllFrom :: PGF -> Expr -> [(Expr,Float)]
generateAllFrom = error "generateAllFrom is not implemented yet"
generateRandom :: RandomGen gen => gen -> PGF -> Type -> [a]
generateRandom = error "generateRandom is not implemented yet"
generateRandomFrom :: RandomGen gen => gen -> PGF -> Expr -> [a]
generateRandomFrom = error "generateRandomFrom is not implemented yet"
-- | The abstract language name is the name of the top-level
-- abstract module
abstractName :: PGF -> AbsName
@@ -448,6 +469,9 @@ graphvizWordAlignment cs opts e =
type Labels = Map.Map Fun [String]
getDepLabels :: String -> Labels
getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)]
-- | Visualize word dependency tree.
graphvizDependencyTree
:: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
@@ -1499,6 +1523,8 @@ alignWords lang e = unsafePerformIO $
(fids :: [CInt]) <- peekArray (fromIntegral (n_fids :: CInt)) (ptr `plusPtr` (#offset PgfAlignmentPhrase, fids))
return (phrase, map fromIntegral fids)
gizaAlignment = error "gizaAlignment is not implemented"
printName :: Concr -> Fun -> Maybe String
printName lang fun =
unsafePerformIO $
@@ -1729,3 +1755,9 @@ capitalized' not s = Nothing
tag i
| i < 0 = char 'r' <> int (negate i)
| otherwise = char 'n' <> int i
readProbabilitiesFromFile :: FilePath -> IO (Map.Map String Double)
readProbabilitiesFromFile fpath = do
s <- readFile fpath
return $ Map.fromList [(f,read p) | f:p:_ <- map words (lines s)]

2
src/runtime/haskell-bind/pgf2.cabal
View File

@@ -18,7 +18,7 @@ library
-- backwards compatibility API:
PGF, PGF.Internal
other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
build-depends: base >=4.3, containers, pretty, array
build-depends: base >=4.3, containers, pretty, array, random
-- hs-source-dirs:
default-language: Haskell2010
build-tools: hsc2hs

5
src/runtime/python/pypgf.c
View File

@@ -2285,7 +2285,10 @@ Concr_getName(ConcrObject *self, void *closure)
static PyObject*
Concr_getLanguageCode(ConcrObject *self, void *closure)
{
return PyString_FromString(pgf_language_code(self->concr));
GuString code = pgf_language_code(self->concr);
if (code == NULL)
Py_RETURN_NONE;
return PyString_FromString(code);
}
static PyObject*

11
src/server/transfer/Fold.hs
View File

@@ -1,14 +1,15 @@
module Fold where
import PGF
import PGF2
import Data.Map as M (lookup, fromList)
--import Debug.Trace
foldable = fromList [(mkCId c, mkCId ("bin_" ++ c)) | c <- ops]
foldable = fromList [(c, "bin_" ++ c) | c <- ops]
where ops = words "plus times and or xor cartesian_product intersect union"
fold :: Tree -> Tree
fold :: Expr -> Expr
fold t =
case unApp t of
Just (i,[x]) ->
@@ -18,9 +19,9 @@ fold t =
Just (i,xs) -> mkApp i $ map fold xs
_ -> t
appFold :: CId -> Tree -> Tree
appFold :: Fun -> Expr -> Expr
appFold j t =
case unApp t of
Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts]
Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s]
where isPre i s = take 4 (show i) == s
where isPre i s = take 4 (show i) == s