mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-14 13:42:50 -06:00
manually copy the "c-runtime" branch from the old repository.
This commit is contained in:
Krasimir Angelov
@@ -11,7 +11,7 @@ type Pipe = [Command]
|
||||
|
||||
data Command
|
||||
= Command Ident [Option] Argument
|
||||
deriving (Eq,Ord,Show)
|
||||
deriving Show
|
||||
|
||||
data Option
|
||||
= OOpt Ident
|
||||
@@ -29,7 +29,7 @@ data Argument
|
||||
| ATerm Term
|
||||
| ANoArg
|
||||
| AMacro Ident
|
||||
deriving (Eq,Ord,Show)
|
||||
deriving Show
|
||||
|
||||
valCIdOpts :: String -> CId -> [Option] -> CId
|
||||
valCIdOpts flag def opts =
|
||||
@@ -49,6 +49,24 @@ 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
|
||||
(v:_) -> fn v
|
||||
_ -> def
|
||||
|
||||
maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
|
||||
maybeStrOpts flag def fn opts =
|
||||
case listFlags flag opts of
|
||||
v:_ -> fn (valueString v)
|
||||
_ -> def
|
||||
|
||||
listFlags flag opts = [v | OFlag f v <- opts, f == flag]
|
||||
|
||||
valueString v =
|
||||
|
||||
@@ -3,8 +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 qualified PGF as H(showExpr)
|
||||
import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ----
|
||||
import PGF(mkStr,unStr,showExpr)
|
||||
|
||||
data CommandInfo m = CommandInfo {
|
||||
exec :: [Option] -> CommandArguments -> m CommandOutput,
|
||||
@@ -44,15 +43,13 @@ newtype CommandOutput = Piped (CommandArguments,String) ---- errors, etc
|
||||
|
||||
-- ** Converting command output
|
||||
fromStrings ss = Piped (Strings ss, unlines ss)
|
||||
fromExprs es = Piped (Exprs es,unlines (map (H.showExpr []) es))
|
||||
fromExprs es = Piped (Exprs es,unlines (map (showExpr []) es))
|
||||
fromString s = Piped (Strings [s], s)
|
||||
pipeWithMessage es msg = Piped (Exprs es,msg)
|
||||
pipeMessage msg = Piped (Exprs [],msg)
|
||||
pipeExprs es = Piped (Exprs es,[]) -- only used in emptyCommandInfo
|
||||
void = Piped (Exprs [],"")
|
||||
|
||||
stringAsExpr = H.ELit . H.LStr -- should be a pattern macro
|
||||
|
||||
-- ** Converting command input
|
||||
|
||||
toStrings args =
|
||||
@@ -62,22 +59,22 @@ toStrings args =
|
||||
Term t -> [render t]
|
||||
where
|
||||
showAsString first t =
|
||||
case t of
|
||||
H.ELit (H.LStr s) -> s
|
||||
_ -> ['\n'|not first] ++
|
||||
H.showExpr [] t ---newline needed in other cases than the first
|
||||
case unStr t of
|
||||
Just s -> s
|
||||
Nothing -> ['\n'|not first] ++
|
||||
showExpr [] t ---newline needed in other cases than the first
|
||||
|
||||
toExprs args =
|
||||
case args of
|
||||
Exprs es -> es
|
||||
Strings ss -> map stringAsExpr ss
|
||||
Term t -> [stringAsExpr (render t)]
|
||||
Strings ss -> map mkStr ss
|
||||
Term t -> [mkStr (render t)]
|
||||
|
||||
toTerm args =
|
||||
case args of
|
||||
Term t -> t
|
||||
Strings ss -> string2term $ unwords ss -- hmm
|
||||
Exprs es -> string2term $ unwords $ map (H.showExpr []) es -- hmm
|
||||
Exprs es -> string2term $ unwords $ map (showExpr []) es -- hmm
|
||||
|
||||
-- ** Creating documentation
|
||||
|
||||
|
||||
@@ -3,14 +3,10 @@ module GF.Command.Commands (
|
||||
PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
|
||||
options,flags,
|
||||
) where
|
||||
import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
import Prelude hiding (putStrLn)
|
||||
|
||||
import PGF
|
||||
|
||||
import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
|
||||
import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
|
||||
import PGF.Internal(ppFun,ppCat)
|
||||
import PGF.Internal(optimizePGF)
|
||||
import PGF.Internal(writePGF)
|
||||
|
||||
import GF.Compile.Export
|
||||
import GF.Compile.ToAPI
|
||||
@@ -28,7 +24,7 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import PGF.Internal (encodeFile)
|
||||
-- import PGF.Internal (encodeFile)
|
||||
import Data.List(intersperse,nub)
|
||||
import Data.Maybe
|
||||
import qualified Data.Map as Map
|
||||
@@ -37,16 +33,22 @@ import Data.List (sort)
|
||||
--import Debug.Trace
|
||||
|
||||
|
||||
data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
|
||||
data PGFEnv = Env {pgf::Maybe PGF,mos::Map.Map Language Morpho}
|
||||
|
||||
pgfEnv pgf = Env pgf mos
|
||||
where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
|
||||
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 = (either (fail . render . ppTcError) (return . fst)
|
||||
. flip inferExpr e . pgf) =<< getPGFEnv
|
||||
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 = Map.fromList [
|
||||
@@ -61,7 +63,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 = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
let es = toExprs arg
|
||||
let langs = optLangs pgf opts
|
||||
if isOpt "giza" opts
|
||||
@@ -95,6 +97,7 @@ pgfCommands = Map.fromList [
|
||||
("view", "program to open the resulting file")
|
||||
]
|
||||
}),
|
||||
|
||||
("ca", emptyCommandInfo {
|
||||
longname = "clitic_analyse",
|
||||
synopsis = "print the analyses of all words into stems and clitics",
|
||||
@@ -105,15 +108,15 @@ 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 = getEnv $ \opts ts env -> case opts of
|
||||
exec = needPGF $ \opts ts pgf mos -> case opts of
|
||||
_ | isOpt "raw" opts ->
|
||||
return . fromString .
|
||||
unlines . map (unwords . map (concat . intersperse "+")) .
|
||||
map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) .
|
||||
map (getClitics (isInMorpho (optMorpho pgf mos opts)) (optClitics opts)) .
|
||||
concatMap words $ toStrings ts
|
||||
_ ->
|
||||
return . fromStrings .
|
||||
getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) .
|
||||
getCliticsText (isInMorpho (optMorpho pgf mos opts)) (optClitics opts) .
|
||||
concatMap words $ toStrings ts,
|
||||
flags = [
|
||||
("clitics","the list of possible clitics (comma-separated, no spaces)"),
|
||||
@@ -146,19 +149,18 @@ pgfCommands = Map.fromList [
|
||||
],
|
||||
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")
|
||||
("lang","the language in which to parse")
|
||||
],
|
||||
exec = getEnv $ \ opts _ env@(Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts _ pgf mos -> do
|
||||
let file = optFile opts
|
||||
pgf <- optProbs opts pgf
|
||||
let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
|
||||
let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
|
||||
let conf = configureExBased pgf (optMorpho pgf mos 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",
|
||||
@@ -180,11 +182,9 @@ pgfCommands = Map.fromList [
|
||||
("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)")
|
||||
("depth","the maximum generation depth")
|
||||
],
|
||||
exec = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
pgf <- optProbs opts (optRestricted opts pgf)
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
gen <- newStdGen
|
||||
let dp = valIntOpts "depth" 4 opts
|
||||
let ts = case mexp (toExprs arg) of
|
||||
@@ -192,6 +192,7 @@ pgfCommands = Map.fromList [
|
||||
Nothing -> 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",
|
||||
@@ -213,14 +214,14 @@ pgfCommands = Map.fromList [
|
||||
mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2",
|
||||
mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))"
|
||||
],
|
||||
exec = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
let pgfr = optRestricted opts pgf
|
||||
exec = needPGF $ \opts arg pgf mos -> do
|
||||
let dp = valIntOpts "depth" 4 opts
|
||||
let ts = case mexp (toExprs arg) of
|
||||
Just ex -> generateFromDepth pgfr ex (Just dp)
|
||||
Nothing -> generateAllDepth pgfr (optType pgf opts) (Just dp)
|
||||
Just ex -> generateFromDepth pgf ex (Just dp)
|
||||
Nothing -> generateAllDepth pgf (optType pgf opts) (Just dp)
|
||||
returnFromExprs $ take (optNumInf opts) ts
|
||||
}),
|
||||
|
||||
("i", emptyCommandInfo {
|
||||
longname = "import",
|
||||
synopsis = "import a grammar from source code or compiled .pgf file",
|
||||
@@ -241,13 +242,13 @@ pgfCommands = Map.fromList [
|
||||
("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",
|
||||
@@ -267,7 +268,7 @@ pgfCommands = Map.fromList [
|
||||
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
|
||||
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
|
||||
],
|
||||
exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings . optLins pgf opts $ toExprs ts,
|
||||
exec = needPGF $ \ opts ts pgf mos -> 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"),
|
||||
@@ -275,7 +276,6 @@ pgfCommands = Map.fromList [
|
||||
("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"),
|
||||
("tabtreebank","show the tree and its linearizations on a tab-separated line"),
|
||||
("treebank","show the tree and tag linearizations with language names")
|
||||
] ++ stringOpOptions,
|
||||
flags = [
|
||||
@@ -283,25 +283,7 @@ pgfCommands = Map.fromList [
|
||||
("unlexer","set unlexers separately to each language (space-separated)")
|
||||
]
|
||||
}),
|
||||
("lc", emptyCommandInfo {
|
||||
longname = "linearize_chunks",
|
||||
synopsis = "linearize a tree that has metavariables in maximal chunks without them",
|
||||
explanation = unlines [
|
||||
"A hopefully temporary command, intended to work around the type checker that fails",
|
||||
"trees where a function node is a metavariable."
|
||||
],
|
||||
examples = [
|
||||
mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)"
|
||||
],
|
||||
exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf (opts ++ [OOpt "chunks"]) (toExprs ts),
|
||||
options = [
|
||||
("treebank","show the tree and tag linearizations with language names")
|
||||
] ++ stringOpOptions,
|
||||
flags = [
|
||||
("lang","the languages of linearization (comma-separated, no spaces)")
|
||||
],
|
||||
needsTypeCheck = False
|
||||
}),
|
||||
|
||||
("ma", emptyCommandInfo {
|
||||
longname = "morpho_analyse",
|
||||
synopsis = "print the morphological analyses of all words in the string",
|
||||
@@ -309,17 +291,17 @@ 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 = getEnv $ \opts ts env -> case opts of
|
||||
exec = needPGF $ \opts ts pgf mos -> case opts of
|
||||
_ | isOpt "missing" opts ->
|
||||
return . fromString . unwords .
|
||||
morphoMissing (optMorpho env opts) .
|
||||
morphoMissing (optMorpho pgf mos opts) .
|
||||
concatMap words $ toStrings ts
|
||||
_ | isOpt "known" opts ->
|
||||
return . fromString . unwords .
|
||||
morphoKnown (optMorpho env opts) .
|
||||
morphoKnown (optMorpho pgf mos opts) .
|
||||
concatMap words $ toStrings ts
|
||||
_ -> return . fromString . unlines .
|
||||
map prMorphoAnalysis . concatMap (morphos env opts) .
|
||||
map prMorphoAnalysis . concatMap (morphos pgf mos opts) .
|
||||
concatMap words $ toStrings ts,
|
||||
flags = [
|
||||
("lang","the languages of analysis (comma-separated, no spaces)")
|
||||
@@ -334,18 +316,16 @@ pgfCommands = Map.fromList [
|
||||
longname = "morpho_quiz",
|
||||
synopsis = "start a morphology quiz",
|
||||
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
|
||||
exec = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
let lang = optLang pgf opts
|
||||
let typ = optType pgf opts
|
||||
pgf <- optProbs opts pgf
|
||||
let mt = mexp (toExprs arg)
|
||||
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")
|
||||
("number","maximum number of questions")
|
||||
]
|
||||
}),
|
||||
|
||||
@@ -362,7 +342,7 @@ pgfCommands = Map.fromList [
|
||||
"the parser. For example if -openclass=\"A,N,V\" is given, the parser",
|
||||
"will accept unknown adjectives, nouns and verbs with the resource grammar."
|
||||
],
|
||||
exec = getEnv $ \ opts ts (Env pgf mos) ->
|
||||
exec = needPGF $ \opts ts pgf mos ->
|
||||
return $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
|
||||
flags = [
|
||||
("cat","target category of parsing"),
|
||||
@@ -374,6 +354,7 @@ pgfCommands = Map.fromList [
|
||||
("bracket","prints the bracketed string from the parser")
|
||||
]
|
||||
}),
|
||||
|
||||
("pg", emptyCommandInfo { -----
|
||||
longname = "print_grammar",
|
||||
synopsis = "print the actual grammar with the given printer",
|
||||
@@ -393,7 +374,7 @@ pgfCommands = Map.fromList [
|
||||
" " ++ opt ++ "\t\t" ++ expl |
|
||||
((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
|
||||
]),
|
||||
exec = getEnv $ \opts _ env -> prGrammar env opts,
|
||||
exec = needPGF $ \opts _ pgf mos -> prGrammar pgf mos opts,
|
||||
flags = [
|
||||
--"cat",
|
||||
("file", "set the file name when printing with -pgf option"),
|
||||
@@ -415,6 +396,7 @@ pgfCommands = Map.fromList [
|
||||
mkEx ("pg -funs | ? grep \" S ;\" -- show functions with value cat S")
|
||||
]
|
||||
}),
|
||||
|
||||
("pt", emptyCommandInfo {
|
||||
longname = "put_tree",
|
||||
syntax = "pt OPT? TREE",
|
||||
@@ -428,11 +410,12 @@ pgfCommands = Map.fromList [
|
||||
examples = [
|
||||
mkEx "pt -compute (plus one two) -- compute value"
|
||||
],
|
||||
exec = getEnv $ \ opts arg (Env pgf mos) ->
|
||||
exec = needPGF $ \opts arg pgf mos ->
|
||||
returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
|
||||
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",
|
||||
@@ -445,10 +428,9 @@ pgfCommands = Map.fromList [
|
||||
],
|
||||
options = [
|
||||
("lines","return the list of lines, instead of the singleton of all contents"),
|
||||
("paragraphs","return the list of paragraphs, as separated by empty lines"),
|
||||
("tree","convert strings into trees")
|
||||
],
|
||||
exec = getEnv $ \ opts _ (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts _ pgf mos -> do
|
||||
let file = valStrOpts "file" "_gftmp" opts
|
||||
let exprs [] = ([],empty)
|
||||
exprs ((n,s):ls) | null s
|
||||
@@ -471,10 +453,10 @@ pgfCommands = Map.fromList [
|
||||
_ | isOpt "tree" opts ->
|
||||
returnFromLines [(1::Int,s)]
|
||||
_ | isOpt "lines" opts -> return (fromStrings $ lines s)
|
||||
_ | isOpt "paragraphs" opts -> return (fromStrings $ toParagraphs $ 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",
|
||||
@@ -484,18 +466,14 @@ pgfCommands = Map.fromList [
|
||||
"by the file given by flag -probs=FILE, where each line has the form",
|
||||
"'function probability', e.g. 'youPol_Pron 0.01'."
|
||||
],
|
||||
exec = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
let ts = toExprs arg
|
||||
pgf <- optProbs opts pgf
|
||||
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,
|
||||
flags = [
|
||||
("probs","probabilities from this file (format 'f 0.6' per line)")
|
||||
],
|
||||
options = [
|
||||
("v","show all trees with their probability scores")
|
||||
],
|
||||
@@ -503,24 +481,23 @@ pgfCommands = Map.fromList [
|
||||
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 = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
let from = optLangFlag "from" pgf opts
|
||||
let to = optLangFlag "to" pgf opts
|
||||
let typ = optType pgf opts
|
||||
let mt = mexp (toExprs arg)
|
||||
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")
|
||||
("number","the maximum number of questions")
|
||||
],
|
||||
examples = [
|
||||
mkEx ("tq -from=Eng -to=Swe -- any trees in startcat"),
|
||||
@@ -528,7 +505,6 @@ pgfCommands = Map.fromList [
|
||||
]
|
||||
}),
|
||||
|
||||
|
||||
("vd", emptyCommandInfo {
|
||||
longname = "visualize_dependency",
|
||||
synopsis = "show word dependency tree graphically",
|
||||
@@ -546,7 +522,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 = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
let absname = abstractName pgf
|
||||
let es = toExprs arg
|
||||
let debug = isOpt "v" opts
|
||||
@@ -595,7 +571,6 @@ pgfCommands = Map.fromList [
|
||||
]
|
||||
}),
|
||||
|
||||
|
||||
("vp", emptyCommandInfo {
|
||||
longname = "visualize_parse",
|
||||
synopsis = "show parse tree graphically",
|
||||
@@ -607,7 +582,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 = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \ opts arg pgf mos -> do
|
||||
let es = toExprs arg
|
||||
let lang = optLang pgf opts
|
||||
let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
|
||||
@@ -660,7 +635,6 @@ pgfCommands = Map.fromList [
|
||||
]
|
||||
}),
|
||||
|
||||
|
||||
("vt", emptyCommandInfo {
|
||||
longname = "visualize_tree",
|
||||
synopsis = "show a set of trees graphically",
|
||||
@@ -673,7 +647,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 = getEnv $ \ opts arg (Env pgf mos) ->
|
||||
exec = needPGF $ \ opts arg pgf mos ->
|
||||
let es = toExprs arg in
|
||||
if isOpt "mk" opts
|
||||
then return $ fromString $ unlines $ map (tree2mk pgf) es
|
||||
@@ -707,6 +681,7 @@ pgfCommands = Map.fromList [
|
||||
("view","program to open the resulting file (default \"open\")")
|
||||
]
|
||||
}),
|
||||
|
||||
("ai", emptyCommandInfo {
|
||||
longname = "abstract_info",
|
||||
syntax = "ai IDENTIFIER or ai EXPR",
|
||||
@@ -719,43 +694,42 @@ pgfCommands = Map.fromList [
|
||||
"If a whole expression is given it prints the expression with refined",
|
||||
"metavariables and the type of the expression."
|
||||
],
|
||||
exec = getEnv $ \ opts arg (Env pgf mos) -> do
|
||||
exec = needPGF $ \opts arg pgf mos -> do
|
||||
case toExprs arg of
|
||||
[EFun id] -> case Map.lookup id (funs (abstract pgf)) of
|
||||
Just fd -> do putStrLn $ render (ppFun id fd)
|
||||
let (_,_,_,prob) = fd
|
||||
putStrLn ("Probability: "++show prob)
|
||||
return void
|
||||
Nothing -> case Map.lookup id (cats (abstract pgf)) of
|
||||
Just cd -> do putStrLn $
|
||||
render (ppCat id cd $$
|
||||
if null (functionsToCat pgf id)
|
||||
then empty
|
||||
else ' ' $$
|
||||
vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
|
||||
' ')
|
||||
let (_,_,prob) = cd
|
||||
putStrLn ("Probability: "++show prob)
|
||||
return void
|
||||
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
|
||||
return void
|
||||
[e] -> case inferExpr pgf e of
|
||||
Left tcErr -> error $ render (ppTcError tcErr)
|
||||
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
|
||||
putStrLn ("Type: "++showType [] ty)
|
||||
putStrLn ("Probability: "++show (probTree pgf e))
|
||||
return void
|
||||
[e] -> case unApp e of
|
||||
Just (id, []) -> case functionType pgf id of
|
||||
Just ty -> do putStrLn (showFun pgf id ty)
|
||||
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)
|
||||
let ls = [showFun pgf fn ty | fn <- functionsByCat pgf id, Just ty <- [functionType pgf fn]]
|
||||
if null ls
|
||||
then return ()
|
||||
else putStrLn (unlines ("":ls))
|
||||
putStrLn ("Probability: "++show (categoryProbability pgf id))
|
||||
return void
|
||||
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
|
||||
return void
|
||||
_ -> case inferExpr pgf e of
|
||||
Left tcErr -> error $ render (ppTcError tcErr)
|
||||
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
|
||||
putStrLn ("Type: "++showType [] ty)
|
||||
putStrLn ("Probability: "++show (treeProbability pgf e))
|
||||
return void
|
||||
_ -> do putStrLn "a single identifier or expression is expected from the command"
|
||||
return void,
|
||||
needsTypeCheck = False
|
||||
})
|
||||
]
|
||||
where
|
||||
getEnv exec opts ts = liftSIO . exec opts ts =<< getPGFEnv
|
||||
needPGF exec opts ts = do
|
||||
Env mb_pgf mos <- getPGFEnv
|
||||
case mb_pgf of
|
||||
Just pgf -> liftSIO $ exec opts ts pgf mos
|
||||
_ -> fail "Import a grammar before using this command"
|
||||
|
||||
par pgf opts s = case optOpenTypes opts of
|
||||
[] -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
|
||||
open_typs -> [parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts]
|
||||
par pgf opts s = [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
|
||||
where
|
||||
dp = valIntOpts "depth" 4 opts
|
||||
|
||||
@@ -794,9 +768,6 @@ pgfCommands = Map.fromList [
|
||||
_ | isOpt "treebank" opts ->
|
||||
(showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
|
||||
[showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
|
||||
_ | isOpt "tabtreebank" opts ->
|
||||
return $ concat $ intersperse "\t" $ (showExpr [] t) :
|
||||
[s | lang <- optLangs pgf opts, s <- linear pgf opts lang t]
|
||||
_ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t
|
||||
_ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
|
||||
linChunks pgf opts t =
|
||||
@@ -816,9 +787,12 @@ pgfCommands = Map.fromList [
|
||||
-- replace each non-atomic constructor with mkC, where C is the val cat
|
||||
tree2mk pgf = showExpr [] . t2m where
|
||||
t2m t = case unApp t of
|
||||
Just (cid,ts@(_:_)) -> mkApp (mk cid) (map t2m ts)
|
||||
_ -> t
|
||||
mk = mkCId . ("mk" ++) . showCId . lookValCat (abstract pgf)
|
||||
Just (cid,ts@(_:_)) -> mkApp (mk cid) (map t2m ts)
|
||||
_ -> t
|
||||
mk f = case functionType pgf f of
|
||||
Just ty -> let (_,cat,_) = unType ty
|
||||
in mkCId ("mk" ++ showCId cat)
|
||||
Nothing -> f
|
||||
|
||||
unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
|
||||
|
||||
@@ -845,8 +819,6 @@ pgfCommands = Map.fromList [
|
||||
in cod : filter (/=cod) (map prOpt opts)
|
||||
_ -> map prOpt opts
|
||||
-}
|
||||
optRestricted opts pgf =
|
||||
restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs pgf opts]) pgf
|
||||
|
||||
optLang = optLangFlag "lang"
|
||||
optLangs = optLangsFlag "lang"
|
||||
@@ -860,26 +832,22 @@ pgfCommands = Map.fromList [
|
||||
else (mkCId (showCId (abstractName pgf) ++ la))
|
||||
|
||||
optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId]
|
||||
|
||||
optOpenTypes opts = case valStrOpts "openclass" "" opts of
|
||||
"" -> []
|
||||
cats -> mapMaybe readType (chunks ',' cats)
|
||||
|
||||
{-
|
||||
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 str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
|
||||
in case readType str of
|
||||
Just ty -> case checkType pgf ty of
|
||||
Left tcErr -> error $ render (ppTcError tcErr)
|
||||
Right ty -> ty
|
||||
Nothing -> error ("Can't parse '"++str++"' as a type")
|
||||
let readOpt str = case readType str of
|
||||
Just ty -> case checkType pgf ty of
|
||||
Left tcErr -> error $ render (ppTcError tcErr)
|
||||
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
|
||||
optViewGraph opts = valStrOpts "view" "open" opts
|
||||
optNum opts = valIntOpts "number" 1 opts
|
||||
@@ -890,34 +858,35 @@ pgfCommands = Map.fromList [
|
||||
[] -> pipeMessage "no trees found"
|
||||
_ -> fromExprs es
|
||||
|
||||
prGrammar (Env pgf mos) opts
|
||||
prGrammar pgf mos opts
|
||||
| isOpt "pgf" opts = do
|
||||
let pgf1 = if isOpt "opt" opts then optimizePGF pgf else pgf
|
||||
let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
|
||||
restricted $ encodeFile outfile pgf1
|
||||
restricted $ writePGF outfile pgf
|
||||
putStrLn $ "wrote file " ++ outfile
|
||||
return void
|
||||
| isOpt "cats" opts = return $ fromString $ unwords $ map showCId $ categories pgf
|
||||
| isOpt "funs" opts = return $ fromString $ unlines $ map showFun $ funsigs 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 "lexc" opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts
|
||||
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) |
|
||||
la <- optLangs pgf opts, let cs = missingLins pgf la]
|
||||
| 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
|
||||
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
|
||||
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
|
||||
|
||||
funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
|
||||
showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
|
||||
showFun pgf id ty = kwd++" "++showCId id ++ " : " ++ showType [] ty
|
||||
where
|
||||
kwd | functionIsDataCon pgf id = "data"
|
||||
| otherwise = "fun"
|
||||
|
||||
morphos (Env pgf mos) opts s =
|
||||
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 (Env pgf mos) opts = morpho mos (error "no morpho") id (head (optLangs pgf opts))
|
||||
optMorpho pgf mos opts = morpho mos (error "no morpho") id (head (optLangs pgf opts))
|
||||
|
||||
optClitics opts = case valStrOpts "clitics" "" opts of
|
||||
"" -> []
|
||||
@@ -961,7 +930,6 @@ prLexcLexicon mo =
|
||||
ws -> map ('+':) ws
|
||||
|
||||
multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p) <- lps]
|
||||
-- thick_A+(AAdj+Posit+Gen):thick's # ;
|
||||
|
||||
prFullFormLexicon :: Morpho -> String
|
||||
prFullFormLexicon mo =
|
||||
@@ -971,7 +939,6 @@ prAllWords :: Morpho -> String
|
||||
prAllWords mo =
|
||||
unwords [w | (w,_) <- fullFormLexicon mo]
|
||||
|
||||
prMorphoAnalysis :: (String,[(Lemma,Analysis)]) -> String
|
||||
prMorphoAnalysis (w,lps) =
|
||||
unlines (w:[showCId l ++ " : " ++ p | (l,p) <- lps])
|
||||
|
||||
|
||||
@@ -3,7 +3,6 @@
|
||||
-- elsewhere
|
||||
module GF.Command.CommonCommands where
|
||||
import Data.List(sort)
|
||||
import Data.Char (isSpace)
|
||||
import GF.Command.CommandInfo
|
||||
import qualified Data.Map as Map
|
||||
import GF.Infra.SIO
|
||||
@@ -117,13 +116,11 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
|
||||
let (os,fs) = optsAndFlags opts
|
||||
trans <- optTranslit opts
|
||||
|
||||
case opts of
|
||||
_ | isOpt "lines" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
|
||||
_ | isOpt "paragraphs" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toParagraphs $ toStrings x
|
||||
_ -> return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
|
||||
if isOpt "lines" opts
|
||||
then return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
|
||||
else return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
|
||||
options = [
|
||||
("lines","apply the operation separately to each input line, returning a list of lines"),
|
||||
("paragraphs","apply separately to each input paragraph (as separated by empty lines), returning a list of lines")
|
||||
("lines","apply the operation separately to each input line, returning a list of lines")
|
||||
] ++
|
||||
stringOpOptions,
|
||||
flags = [
|
||||
@@ -272,11 +269,3 @@ trie = render . pptss . H.toTrie . map H.toATree
|
||||
-- ** Converting command input
|
||||
toString = unwords . toStrings
|
||||
toLines = unlines . toStrings
|
||||
|
||||
toParagraphs = map (unwords . words) . toParas
|
||||
where
|
||||
toParas ls = case break (all isSpace) ls of
|
||||
([],[]) -> []
|
||||
([],_:ll) -> toParas ll
|
||||
(l, []) -> [unwords l]
|
||||
(l, _:ll) -> unwords l : toParas ll
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
module GF.Command.Importing (importGrammar, importSource) where
|
||||
|
||||
import PGF
|
||||
import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
|
||||
import PGF.Internal(unionPGF)
|
||||
|
||||
import GF.Compile
|
||||
import GF.Compile.Multi (readMulti)
|
||||
@@ -17,14 +17,16 @@ import GF.Data.ErrM
|
||||
|
||||
import System.FilePath
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad(foldM)
|
||||
|
||||
-- import a grammar in an environment where it extends an existing grammar
|
||||
importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
|
||||
importGrammar pgf0 _ [] = return pgf0
|
||||
importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
|
||||
importGrammar pgf0 _ [] = return pgf0
|
||||
importGrammar pgf0 opts files =
|
||||
case takeExtensions (last files) of
|
||||
".cf" -> importCF opts files getBNFCRules bnfc2cf
|
||||
".ebnf" -> importCF opts files getEBNFRules ebnf2cf
|
||||
".cf" -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
|
||||
".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
|
||||
".gfm" -> do
|
||||
ascss <- mapM readMulti files
|
||||
let cs = concatMap snd ascss
|
||||
@@ -36,14 +38,15 @@ importGrammar pgf0 opts files =
|
||||
Bad msg -> do putStrLn ('\n':'\n':msg)
|
||||
return pgf0
|
||||
".pgf" -> do
|
||||
pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
|
||||
ioUnionPGF pgf0 pgf2
|
||||
mapM readPGF files >>= foldM ioUnionPGF pgf0
|
||||
ext -> die $ "Unknown filename extension: " ++ show ext
|
||||
|
||||
ioUnionPGF :: PGF -> PGF -> IO PGF
|
||||
ioUnionPGF one two = case msgUnionPGF one two of
|
||||
(pgf, Just msg) -> putStrLn msg >> return pgf
|
||||
(pgf,_) -> return pgf
|
||||
ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
|
||||
ioUnionPGF Nothing two = return (Just two)
|
||||
ioUnionPGF (Just one) two =
|
||||
case unionPGF one two of
|
||||
Nothing -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two)
|
||||
Just pgf -> return (Just pgf)
|
||||
|
||||
importSource :: Options -> [FilePath] -> IO SourceGrammar
|
||||
importSource opts files = fmap (snd.snd) (batchCompile opts files)
|
||||
@@ -56,7 +59,6 @@ importCF opts files get convert = impCF
|
||||
startCat <- case rules of
|
||||
(Rule cat _ _ : _) -> return cat
|
||||
_ -> fail "empty CFG"
|
||||
let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
|
||||
probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
|
||||
return $ setProbabilities probs
|
||||
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf
|
||||
probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
|
||||
let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
|
||||
return pgf
|
||||
|
||||
@@ -6,7 +6,7 @@ module GF.Command.Interpreter (
|
||||
import GF.Command.CommandInfo
|
||||
import GF.Command.Abstract
|
||||
import GF.Command.Parse
|
||||
import PGF.Internal(Expr(..))
|
||||
import PGF
|
||||
import GF.Infra.UseIO(putStrLnE)
|
||||
|
||||
import Control.Monad(when)
|
||||
@@ -53,17 +53,8 @@ interpretPipe env cs = do
|
||||
-- | macro definition applications: replace ?i by (exps !! i)
|
||||
appCommand :: CommandArguments -> Command -> Command
|
||||
appCommand args c@(Command i os arg) = case arg of
|
||||
AExpr e -> Command i os (AExpr (app e))
|
||||
AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
|
||||
_ -> c
|
||||
where
|
||||
xs = toExprs args
|
||||
|
||||
app e = case e of
|
||||
EAbs b x e -> EAbs b x (app e)
|
||||
EApp e1 e2 -> EApp (app e1) (app e2)
|
||||
ELit l -> ELit l
|
||||
EMeta i -> xs !! i
|
||||
EFun x -> EFun x
|
||||
|
||||
-- | return the trees to be sent in pipe, and the output possibly printed
|
||||
--interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
|
||||
|
||||
import GF.Compile.GrammarToPGF(mkCanon2pgf)
|
||||
import GF.Compile.GrammarToPGF(grammar2PGF)
|
||||
import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
|
||||
importsOfModule)
|
||||
import GF.CompileOne(compileOne)
|
||||
@@ -14,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
|
||||
justModuleName,extendPathEnv,putStrE,putPointE)
|
||||
import GF.Data.Operations(raise,(+++),err)
|
||||
|
||||
import Control.Monad(foldM,when,(<=<),filterM,liftM)
|
||||
import Control.Monad(foldM,when,(<=<))
|
||||
import GF.System.Directory(doesFileExist,getModificationTime)
|
||||
import System.FilePath((</>),isRelative,dropFileName)
|
||||
import qualified Data.Map as Map(empty,insert,elems) --lookup
|
||||
@@ -22,8 +22,7 @@ import Data.List(nub)
|
||||
import Data.Time(UTCTime)
|
||||
import GF.Text.Pretty(render,($$),(<+>),nest)
|
||||
|
||||
import PGF.Internal(optimizePGF)
|
||||
import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
|
||||
import PGF(PGF,readProbabilitiesFromFile)
|
||||
|
||||
-- | Compiles a number of source files and builds a 'PGF' structure for them.
|
||||
-- This is a composition of 'link' and 'batchCompile'.
|
||||
@@ -36,11 +35,10 @@ link :: Options -> (ModuleName,Grammar) -> IOE PGF
|
||||
link opts (cnc,gr) =
|
||||
putPointE Normal opts "linking ... " $ do
|
||||
let abs = srcAbsName gr cnc
|
||||
pgf <- mkCanon2pgf opts gr abs
|
||||
probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
|
||||
probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
|
||||
pgf <- grammar2PGF opts gr abs probs
|
||||
when (verbAtLeast opts Normal) $ putStrE "OK"
|
||||
return $ setProbabilities probs
|
||||
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf
|
||||
return pgf
|
||||
|
||||
-- | Returns the name of the abstract syntax corresponding to the named concrete syntax
|
||||
srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
|
||||
@@ -78,14 +76,10 @@ compileModule opts1 env@(_,rfs) file =
|
||||
do file <- getRealFile file
|
||||
opts0 <- getOptionsFromFile file
|
||||
let curr_dir = dropFileName file
|
||||
lib_dirs <- getLibraryDirectory (addOptions opts0 opts1)
|
||||
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dirs opts0) opts1
|
||||
-- putIfVerb opts $ "curr_dir:" +++ show curr_dir ----
|
||||
-- putIfVerb opts $ "lib_dir:" +++ show lib_dirs ----
|
||||
lib_dir <- getLibraryDirectory (addOptions opts0 opts1)
|
||||
let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
|
||||
ps0 <- extendPathEnv opts
|
||||
let ps = nub (curr_dir : ps0)
|
||||
-- putIfVerb opts $ "options from file: " ++ show opts0
|
||||
-- putIfVerb opts $ "augmented options: " ++ show opts
|
||||
putIfVerb opts $ "module search path:" +++ show ps ----
|
||||
files <- getAllFiles opts ps rfs file
|
||||
putIfVerb opts $ "files to read:" +++ show files ----
|
||||
@@ -98,17 +92,13 @@ compileModule opts1 env@(_,rfs) file =
|
||||
if exists
|
||||
then return file
|
||||
else if isRelative file
|
||||
then do
|
||||
lib_dirs <- getLibraryDirectory opts1
|
||||
let candidates = [ lib_dir </> file | lib_dir <- lib_dirs ]
|
||||
putIfVerb opts1 (render ("looking for: " $$ nest 2 candidates))
|
||||
file1s <- filterM doesFileExist candidates
|
||||
case length file1s of
|
||||
0 -> raise (render ("Unable to find: " $$ nest 2 candidates))
|
||||
1 -> do return $ head file1s
|
||||
_ -> do putIfVerb opts1 ("matched multiple candidates: " +++ show file1s)
|
||||
return $ head file1s
|
||||
else raise (render ("File" <+> file <+> "does not exist"))
|
||||
then do lib_dir <- getLibraryDirectory opts1
|
||||
let file1 = lib_dir </> file
|
||||
exists <- doesFileExist file1
|
||||
if exists
|
||||
then return file1
|
||||
else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
|
||||
else raise (render ("File" <+> file <+> "does not exist."))
|
||||
|
||||
compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
|
||||
compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
|
||||
module GF.Compile.CFGtoPGF (cf2pgf) where
|
||||
|
||||
import GF.Grammar.CFG
|
||||
import GF.Infra.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.Compile.OptimizePGF
|
||||
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
@@ -12,88 +14,97 @@ import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.Array.IArray
|
||||
import Data.List
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
--------------------------
|
||||
-- the compiler ----------
|
||||
--------------------------
|
||||
|
||||
cf2pgf :: FilePath -> ParamCFG -> PGF
|
||||
cf2pgf fpath cf =
|
||||
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
|
||||
in updateProductionIndices pgf
|
||||
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map CId 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
|
||||
|
||||
cf2abstr :: ParamCFG -> Abstr
|
||||
cf2abstr cfg = Abstr aflags afuns acats
|
||||
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map CId Double -> B s AbstrInfo
|
||||
cf2abstr cfg probs = newAbstr aflags acats afuns
|
||||
where
|
||||
aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
|
||||
aflags = [(mkCId "startcat", LStr (fst (cfgStartCat cfg)))]
|
||||
|
||||
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
|
||||
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
|
||||
[(cat2id cat, catRules cfg cat) |
|
||||
cat <- allCats' cfg]]
|
||||
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
|
||||
| rule <- allRules 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)))
|
||||
| rule <- allRules cfg
|
||||
, let f' = mkRuleName rule]
|
||||
|
||||
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
|
||||
[(cat,[(f',Map.lookup f' probs)]) | rule <- allRules cfg,
|
||||
let cat = cat2id (ruleLhs rule),
|
||||
let f' = mkRuleName rule]
|
||||
where
|
||||
pad :: [(a,Maybe Double)] -> [(a,Double)]
|
||||
pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
|
||||
where
|
||||
deflt = case length [f | (f,Nothing) <- pfs] of
|
||||
0 -> 0
|
||||
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
|
||||
|
||||
toLogProb = realToFrac . negate . log
|
||||
|
||||
cat2id = mkCId . fst
|
||||
|
||||
cf2concr :: ParamCFG -> Concr
|
||||
cf2concr cfg = Concr Map.empty Map.empty
|
||||
cncfuns lindefsrefs lindefsrefs
|
||||
sequences productions
|
||||
IntMap.empty Map.empty
|
||||
cnccats
|
||||
IntMap.empty
|
||||
totalCats
|
||||
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)
|
||||
(lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
|
||||
in newConcr abstr [] []
|
||||
lindefs' linrefs'
|
||||
productions' cncfuns'
|
||||
sequences' cnccats' totalCats
|
||||
where
|
||||
cats = allCats' cfg
|
||||
rules = allRules cfg
|
||||
|
||||
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
|
||||
map mkSequence rules)
|
||||
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
|
||||
idSeq = [SymCat 0 0]
|
||||
|
||||
idFun = CncFun [wildCId] (listArray (0,0) [seqid])
|
||||
where
|
||||
seq = listArray (0,0) [SymCat 0 0]
|
||||
seqid = binSearch seq sequences (bounds sequences)
|
||||
sequences0 = Set.fromList (idSeq :
|
||||
map mkSequence rules)
|
||||
sequences = Set.toList sequences0
|
||||
|
||||
idFun = (wildCId,[Set.findIndex idSeq sequences0])
|
||||
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
|
||||
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
|
||||
cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
|
||||
cncfuns = reverse cncfuns0
|
||||
|
||||
lbls = listArray (0,0) ["s"]
|
||||
(fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
|
||||
[(c,p) | (c,ps) <- cats, p <- ps]
|
||||
lbls = ["s"]
|
||||
(fid,cnccats) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
|
||||
[(c,p) | (c,ps) <- cats, p <- ps]
|
||||
((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
|
||||
cnccats = Map.fromList cnccats0
|
||||
|
||||
lindefsrefs =
|
||||
IntMap.fromList (map mkLinDefRef cats)
|
||||
lindefsrefs = map mkLinDefRef cats
|
||||
|
||||
convertRule cs (funid,funs) rule =
|
||||
let args = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
|
||||
prod = PApply funid args
|
||||
seqid = binSearch (mkSequence rule) sequences (bounds sequences)
|
||||
fun = CncFun [mkRuleName rule] (listArray (0,0) [seqid])
|
||||
seqid = Set.findIndex (mkSequence rule) sequences0
|
||||
fun = (mkRuleName rule, [seqid])
|
||||
funid' = funid+1
|
||||
in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
|
||||
|
||||
mkSequence rule = listArray (0,length syms-1) syms
|
||||
mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
|
||||
where
|
||||
syms = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
|
||||
|
||||
convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
|
||||
convertSymbol d (Terminal t) = (d, SymKS t)
|
||||
|
||||
mkCncCat fid (cat,n)
|
||||
| cat == "Int" = (fid, (mkCId cat, CncCat fidInt fidInt lbls))
|
||||
| cat == "Float" = (fid, (mkCId cat, CncCat fidFloat fidFloat lbls))
|
||||
| cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
|
||||
| cat == "Int" = (fid, (mkCId cat, fidInt, fidInt, lbls))
|
||||
| cat == "Float" = (fid, (mkCId cat, fidFloat, fidFloat, lbls))
|
||||
| cat == "String" = (fid, (mkCId cat, fidString, fidString, lbls))
|
||||
| otherwise = let fid' = fid+n+1
|
||||
in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
|
||||
in fid' `seq` (fid', (mkCId cat, fid, fid+n, lbls))
|
||||
|
||||
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
|
||||
mkCoercions (fid,cs) c@(cat,ps ) =
|
||||
@@ -102,25 +113,16 @@ cf2concr cfg = Concr Map.empty Map.empty
|
||||
|
||||
mkLinDefRef (cat,_) =
|
||||
(cat2fid cat 0,[0])
|
||||
|
||||
|
||||
addProd prods (fid,prod) =
|
||||
case IntMap.lookup fid prods of
|
||||
Just set -> IntMap.insert fid (Set.insert prod set) prods
|
||||
Nothing -> IntMap.insert fid (Set.singleton prod) prods
|
||||
|
||||
binSearch v arr (i,j)
|
||||
| i <= j = case compare v (arr ! k) of
|
||||
LT -> binSearch v arr (i,k-1)
|
||||
EQ -> k
|
||||
GT -> binSearch v arr (k+1,j)
|
||||
| otherwise = error "binSearch"
|
||||
where
|
||||
k = (i+j) `div` 2
|
||||
Just set -> IntMap.insert fid (prod:set) prods
|
||||
Nothing -> IntMap.insert fid [prod] prods
|
||||
|
||||
cat2fid cat p =
|
||||
case Map.lookup (mkCId cat) cnccats of
|
||||
Just (CncCat fid _ _) -> fid+p
|
||||
_ -> error "cat2fid"
|
||||
case [start | (cat',start,_,_) <- cnccats, mkCId cat == cat'] of
|
||||
(start:_) -> fid+p
|
||||
_ -> error "cat2fid"
|
||||
|
||||
cat2arg c@(cat,[p]) = cat2fid cat p
|
||||
cat2arg c@(cat,ps ) =
|
||||
@@ -132,3 +134,4 @@ mkRuleName rule =
|
||||
case ruleName rule of
|
||||
CFObj n _ -> n
|
||||
_ -> wildCId
|
||||
|
||||
|
||||
@@ -21,7 +21,6 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Compile.CheckGrammar(checkModule) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
|
||||
@@ -5,7 +5,6 @@ module GF.Compile.Compute.ConcreteNew
|
||||
normalForm,
|
||||
Value(..), Bind(..), Env, value2term, eval, vapply
|
||||
) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
|
||||
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module GF.Compile.Export where
|
||||
|
||||
import PGF
|
||||
import PGF.Internal(ppPGF)
|
||||
import GF.Compile.PGFtoHaskell
|
||||
import GF.Compile.PGFtoJava
|
||||
import GF.Compile.PGFtoProlog
|
||||
@@ -33,7 +32,7 @@ exportPGF :: Options
|
||||
-> [(FilePath,String)] -- ^ List of recommended file names and contents.
|
||||
exportPGF opts fmt pgf =
|
||||
case fmt of
|
||||
FmtPGFPretty -> multi "txt" (render . ppPGF)
|
||||
FmtPGFPretty -> multi "txt" (showPGF)
|
||||
FmtJavaScript -> multi "js" pgf2js
|
||||
FmtPython -> multi "py" pgf2python
|
||||
FmtHaskell -> multi "hs" (grammar2haskell opts name)
|
||||
|
||||
@@ -1,14 +1,15 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Compile.GenerateBC(generateByteCode) where
|
||||
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
|
||||
import GF.Data.Operations
|
||||
import PGF(CId,utf8CId)
|
||||
import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
|
||||
import qualified Data.Map as Map
|
||||
import Data.List(nub,mapAccumL)
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
#if C_RUNTIME
|
||||
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
|
||||
generateByteCode gr arity eqs =
|
||||
let (bs,instrs) = compileEquations gr arity (arity+1) is
|
||||
@@ -63,7 +64,7 @@ compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty
|
||||
|
||||
case_instr t =
|
||||
case t of
|
||||
(Q (_,id)) -> CASE (i2i id)
|
||||
(Q (_,id)) -> CASE (showIdent id)
|
||||
(EInt n) -> CASE_LIT (LInt n)
|
||||
(K s) -> CASE_LIT (LStr s)
|
||||
(EFloat d) -> CASE_LIT (LFlt d)
|
||||
@@ -105,7 +106,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
|
||||
compileFun gr eval st vs (Q (m,id)) h0 bs args =
|
||||
case lookupAbsDef gr m id of
|
||||
Ok (_,Just _)
|
||||
-> (h0,bs,eval st (GLOBAL (i2i id)) args)
|
||||
-> (h0,bs,eval st (GLOBAL (showIdent id)) args)
|
||||
_ -> let Ok ty = lookupFunType gr m id
|
||||
(ctxt,_,_) = typeForm ty
|
||||
c_arity = length ctxt
|
||||
@@ -114,14 +115,14 @@ compileFun gr eval st vs (Q (m,id)) h0 bs args =
|
||||
diff = c_arity-n_args
|
||||
in if diff <= 0
|
||||
then if n_args == 0
|
||||
then (h0,bs,eval st (GLOBAL (i2i id)) [])
|
||||
then (h0,bs,eval st (GLOBAL (showIdent id)) [])
|
||||
else let h1 = h0 + 2 + n_args
|
||||
in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
|
||||
in (h1,bs,PUT_CONSTR (showIdent id):is1++eval st (HEAP h0) [])
|
||||
else let h1 = h0 + 1 + n_args
|
||||
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
|
||||
b = CHECK_ARGS diff :
|
||||
ALLOC (c_arity+2) :
|
||||
PUT_CONSTR (i2i id) :
|
||||
PUT_CONSTR (showIdent id) :
|
||||
is2 ++
|
||||
TUCK (ARG_VAR 0) diff :
|
||||
EVAL (HEAP h0) (TailCall diff) :
|
||||
@@ -167,16 +168,16 @@ compileFun gr eval st vs e _ _ _ = error (show e)
|
||||
|
||||
compileArg gr st vs (Q(m,id)) h0 bs =
|
||||
case lookupAbsDef gr m id of
|
||||
Ok (_,Just _) -> (h0,bs,GLOBAL (i2i id),[])
|
||||
Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
|
||||
_ -> let Ok ty = lookupFunType gr m id
|
||||
(ctxt,_,_) = typeForm ty
|
||||
c_arity = length ctxt
|
||||
in if c_arity == 0
|
||||
then (h0,bs,GLOBAL (i2i id),[])
|
||||
then (h0,bs,GLOBAL (showIdent id),[])
|
||||
else let is2 = [SET (ARG_VAR (i+1)) | i <- [0..c_arity-1]]
|
||||
b = CHECK_ARGS c_arity :
|
||||
ALLOC (c_arity+2) :
|
||||
PUT_CONSTR (i2i id) :
|
||||
PUT_CONSTR (showIdent id) :
|
||||
is2 ++
|
||||
TUCK (ARG_VAR 0) c_arity :
|
||||
EVAL (HEAP h0) (TailCall c_arity) :
|
||||
@@ -224,12 +225,12 @@ compileArg gr st vs e h0 bs =
|
||||
diff = c_arity-n_args
|
||||
in if diff <= 0
|
||||
then let h2 = h1 + 2 + n_args
|
||||
in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (i2i id) : is2))
|
||||
in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent id) : is2))
|
||||
else let h2 = h1 + 1 + n_args
|
||||
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
|
||||
b = CHECK_ARGS diff :
|
||||
ALLOC (c_arity+2) :
|
||||
PUT_CONSTR (i2i id) :
|
||||
PUT_CONSTR (showIdent id) :
|
||||
is2 ++
|
||||
TUCK (ARG_VAR 0) diff :
|
||||
EVAL (HEAP h0) (TailCall diff) :
|
||||
@@ -298,9 +299,10 @@ freeVars xs (Vr x)
|
||||
| not (elem x xs) = [x]
|
||||
freeVars xs e = collectOp (freeVars xs) e
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i = utf8CId . ident2utf8
|
||||
|
||||
push_is :: Int -> Int -> [IVal] -> [IVal]
|
||||
push_is i 0 is = is
|
||||
push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is
|
||||
|
||||
#else
|
||||
generateByteCode = error "generateByteCode is not implemented"
|
||||
#endif
|
||||
|
||||
@@ -14,7 +14,7 @@ module GF.Compile.GeneratePMCFG
|
||||
) where
|
||||
|
||||
--import PGF.CId
|
||||
import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
|
||||
import PGF.Internal as PGF(CId,Symbol(..),fidVar)
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Grammar hiding (Env, mkRecord, mkTable)
|
||||
@@ -157,12 +157,15 @@ convert opts gr cenv loc term ty@(_,val) pargs =
|
||||
args = map Vr vars
|
||||
vars = map (\(bt,x,t) -> x) context
|
||||
|
||||
pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
|
||||
pgfCncCat gr lincat index =
|
||||
pgfCncCat :: SourceGrammar -> CId -> Type -> Int -> (CId,Int,Int,[String])
|
||||
pgfCncCat gr id lincat index =
|
||||
let ((_,size),schema) = computeCatRange gr lincat
|
||||
in PGF.CncCat index (index+size-1)
|
||||
(mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
|
||||
(getStrPaths schema)))
|
||||
in ( id
|
||||
, index
|
||||
, index+size-1
|
||||
, map (renderStyle style{mode=OneLineMode} . ppPath)
|
||||
(getStrPaths schema)
|
||||
)
|
||||
where
|
||||
getStrPaths :: Schema Identity s c -> [Path]
|
||||
getStrPaths = collect CNil []
|
||||
@@ -500,13 +503,11 @@ mapAccumL' f s (x:xs) = (s'',y:ys)
|
||||
!(s'',ys) = mapAccumL' f s' xs
|
||||
|
||||
addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
|
||||
addSequence seqs lst =
|
||||
addSequence seqs seq =
|
||||
case Map.lookup seq seqs of
|
||||
Just id -> (seqs,id)
|
||||
Nothing -> let !last_seq = Map.size seqs
|
||||
in (Map.insert seq last_seq seqs, last_seq)
|
||||
where
|
||||
seq = mkArray lst
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
@@ -52,11 +52,9 @@ getSourceModule opts file0 =
|
||||
let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
|
||||
optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
|
||||
case (optCoding,optCoding') of
|
||||
{-
|
||||
(Nothing,Nothing) ->
|
||||
unless (BS.all isAscii raw) $
|
||||
ePutStrLn $ file0++":\n Warning: default encoding has changed from Latin-1 to UTF-8"
|
||||
-}
|
||||
(_,Just coding') ->
|
||||
when (coding/=coding') $
|
||||
raise $ "Encoding mismatch: "++coding++" /= "++coding'
|
||||
|
||||
@@ -1,17 +1,14 @@
|
||||
{-# LANGUAGE BangPatterns, FlexibleContexts #-}
|
||||
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
|
||||
{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts #-}
|
||||
module GF.Compile.GrammarToPGF (grammar2PGF) where
|
||||
|
||||
--import GF.Compile.Export
|
||||
import GF.Compile.GeneratePMCFG
|
||||
import GF.Compile.GenerateBC
|
||||
import GF.Compile.OptimizePGF
|
||||
|
||||
import PGF(CId,mkCId,utf8CId)
|
||||
import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
|
||||
import PGF.Internal(updateProductionIndices)
|
||||
import qualified PGF.Internal as C
|
||||
import PGF(CId,mkCId,Type,Hypo,Expr)
|
||||
import PGF.Internal
|
||||
import GF.Grammar.Predef
|
||||
--import GF.Grammar.Printer
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Grammar hiding (Production)
|
||||
import qualified GF.Grammar.Lookup as Look
|
||||
import qualified GF.Grammar as A
|
||||
import qualified GF.Grammar.Macros as GM
|
||||
@@ -26,104 +23,132 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.Array.IArray
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE C.PGF
|
||||
mkCanon2pgf opts gr am = do
|
||||
(an,abs) <- mkAbstr am
|
||||
cncs <- mapM mkConcr (allConcretes gr am)
|
||||
return $ updateProductionIndices (C.PGF Map.empty an abs (Map.fromList cncs))
|
||||
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map CId Double -> IO PGF
|
||||
grammar2PGF opts gr am probs = do
|
||||
cnc_infos <- getConcreteInfos gr am
|
||||
return $
|
||||
build (let gflags = if flag optSplitPGF opts
|
||||
then [(mkCId "split", LStr "true")]
|
||||
else []
|
||||
(an,abs) = mkAbstr am probs
|
||||
cncs = map (mkConcr opts abs) cnc_infos
|
||||
in newPGF gflags an abs cncs)
|
||||
where
|
||||
cenv = resourceValues opts gr
|
||||
aflags = err (const noOptions) mflags (lookupModule gr am)
|
||||
|
||||
mkAbstr am = return (mi2i am, C.Abstr flags funs cats)
|
||||
mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map CId Double -> (CId, B s AbstrInfo)
|
||||
mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
|
||||
where
|
||||
aflags = err (const noOptions) mflags (lookupModule gr am)
|
||||
|
||||
adefs =
|
||||
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
|
||||
Look.allOrigInfos gr am
|
||||
|
||||
flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
|
||||
flags = [(mkCId f,x) | (f,x) <- optionsPGF aflags]
|
||||
|
||||
funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) |
|
||||
toLogProb = realToFrac . negate . log
|
||||
|
||||
cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
|
||||
((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
|
||||
|
||||
funs = [(f', mkType [] ty, arity, {-mkDef gr arity mdef,-} toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
|
||||
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
|
||||
let arity = mkArity ma mdef ty]
|
||||
let arity = mkArity ma mdef ty,
|
||||
let f' = i2i f]
|
||||
|
||||
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
|
||||
[(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
|
||||
let (_,(_,cat),_) = GM.typeForm ty,
|
||||
let f' = i2i f]
|
||||
where
|
||||
pad :: [(a,Maybe Double)] -> [(a,Double)]
|
||||
pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
|
||||
where
|
||||
deflt = case length [f | (f,Nothing) <- pfs] of
|
||||
0 -> 0
|
||||
n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
|
||||
|
||||
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
|
||||
((m,c),AbsCat (Just (L _ cont))) <- adefs]
|
||||
|
||||
catfuns cat =
|
||||
[(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
|
||||
|
||||
mkConcr cm = do
|
||||
let cflags = err (const noOptions) mflags (lookupModule gr cm)
|
||||
|
||||
(ex_seqs,cdefs) <- addMissingPMCFGs
|
||||
Map.empty
|
||||
([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
|
||||
Look.allOrigInfos gr cm)
|
||||
|
||||
let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
|
||||
mkConcr opts abs (cm,ex_seqs,cdefs) =
|
||||
let cflags = err (const noOptions) mflags (lookupModule gr cm)
|
||||
flags = [(mkCId f,x) | (f,x) <- optionsPGF cflags]
|
||||
|
||||
seqs = (mkSetArray . Set.fromList . concat) $
|
||||
(Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
|
||||
|
||||
ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
|
||||
(elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
|
||||
|
||||
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
|
||||
cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
|
||||
!(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
|
||||
= genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
|
||||
|
||||
= genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt1 cnccat_ranges
|
||||
|
||||
printnames = genPrintNames cdefs
|
||||
return (mi2i cm, C.Concr flags
|
||||
printnames
|
||||
cncfuns
|
||||
lindefs
|
||||
linrefs
|
||||
seqs
|
||||
productions
|
||||
IntMap.empty
|
||||
Map.empty
|
||||
cnccats
|
||||
IntMap.empty
|
||||
fid_cnt2)
|
||||
|
||||
startCat = mkCId (fromMaybe "S" (flag optStartCat aflags))
|
||||
|
||||
(lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
|
||||
(if flag optOptimizePGF opts then optimizePGF startCat else id)
|
||||
(lindefs,linrefs,productions,cncfuns,elems seqs,cnccats)
|
||||
|
||||
in (mi2i cm, newConcr abs
|
||||
flags
|
||||
printnames
|
||||
lindefs'
|
||||
linrefs'
|
||||
productions'
|
||||
cncfuns'
|
||||
sequences'
|
||||
cnccats'
|
||||
fid_cnt2)
|
||||
|
||||
getConcreteInfos gr am = mapM flatten (allConcretes gr am)
|
||||
where
|
||||
flatten cm = do
|
||||
(seqs,infos) <- addMissingPMCFGs cm Map.empty
|
||||
(lit_infos ++ Look.allOrigInfos gr cm)
|
||||
return (cm,mkMapArray seqs :: Array SeqId [Symbol],infos)
|
||||
|
||||
lit_infos = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]]
|
||||
|
||||
-- if some module was compiled with -no-pmcfg, then
|
||||
-- we have to create the PMCFG code just before linking
|
||||
addMissingPMCFGs seqs [] = return (seqs,[])
|
||||
addMissingPMCFGs seqs (((m,id), info):is) = do
|
||||
(seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
|
||||
(seqs,is ) <- addMissingPMCFGs seqs is
|
||||
return (seqs, ((m,id), info) : is)
|
||||
addMissingPMCFGs cm seqs [] = return (seqs,[])
|
||||
addMissingPMCFGs cm seqs (((m,id), info):is) = do
|
||||
(seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
|
||||
(seqs,infos) <- addMissingPMCFGs cm seqs is
|
||||
return (seqs, ((m,id), info) : infos)
|
||||
|
||||
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
|
||||
mkMapArray map = array (0,Map.size map-1) [(k,v) | (v,k) <- Map.toList map]
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i = utf8CId . ident2utf8
|
||||
i2i = mkCId . showIdent
|
||||
|
||||
mi2i :: ModuleName -> CId
|
||||
mi2i (MN i) = i2i i
|
||||
|
||||
mkType :: [Ident] -> A.Type -> C.Type
|
||||
mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF.Type
|
||||
mkType scope t =
|
||||
case GM.typeForm t of
|
||||
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
|
||||
in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
|
||||
in dTyp hyps' (i2i cat) (map (mkExp scope') args)
|
||||
|
||||
mkExp :: [Ident] -> A.Term -> C.Expr
|
||||
mkExp scope t =
|
||||
mkExp :: (?builder :: Builder s) => [Ident] -> A.Term -> B s Expr
|
||||
mkExp scope t =
|
||||
case t of
|
||||
Q (_,c) -> C.EFun (i2i c)
|
||||
QC (_,c) -> C.EFun (i2i c)
|
||||
Q (_,c) -> eFun (i2i c)
|
||||
QC (_,c) -> eFun (i2i c)
|
||||
Vr x -> case lookup x (zip scope [0..]) of
|
||||
Just i -> C.EVar i
|
||||
Nothing -> C.EMeta 0
|
||||
Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
|
||||
App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
|
||||
EInt i -> C.ELit (C.LInt (fromIntegral i))
|
||||
EFloat f -> C.ELit (C.LFlt f)
|
||||
K s -> C.ELit (C.LStr s)
|
||||
Meta i -> C.EMeta i
|
||||
_ -> C.EMeta 0
|
||||
|
||||
Just i -> eVar i
|
||||
Nothing -> eMeta 0
|
||||
Abs b x t-> eAbs b (i2i x) (mkExp (x:scope) t)
|
||||
App t1 t2-> eApp (mkExp scope t1) (mkExp scope t2)
|
||||
EInt i -> eLit (LInt (fromIntegral i))
|
||||
EFloat f -> eLit (LFlt f)
|
||||
K s -> eLit (LStr s)
|
||||
Meta i -> eMeta i
|
||||
_ -> eMeta 0
|
||||
{-
|
||||
mkPatt scope p =
|
||||
case p of
|
||||
A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
|
||||
@@ -138,147 +163,146 @@ mkPatt scope p =
|
||||
A.PImplArg p-> let (scope',p') = mkPatt scope p
|
||||
in (scope',C.PImplArg p')
|
||||
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
|
||||
|
||||
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
|
||||
-}
|
||||
mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF.Hypo])
|
||||
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
|
||||
in if x == identW
|
||||
then ( scope,(bt,i2i x,ty'))
|
||||
else (x:scope,(bt,i2i x,ty'))) scope hyps
|
||||
|
||||
then ( scope,hypo bt (i2i x) ty')
|
||||
else (x:scope,hypo bt (i2i x) ty')) scope hyps
|
||||
{-
|
||||
mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
|
||||
,generateByteCode gr arity eqs
|
||||
)
|
||||
mkDef gr arity Nothing = Nothing
|
||||
|
||||
-}
|
||||
mkArity (Just a) _ ty = a -- known arity, i.e. defined function
|
||||
mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom
|
||||
mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor
|
||||
in length ctxt
|
||||
|
||||
genCncCats gr am cm cdefs =
|
||||
let (index,cats) = mkCncCats 0 cdefs
|
||||
in (index, Map.fromList cats)
|
||||
genCncCats gr am cm cdefs = mkCncCats 0 cdefs
|
||||
where
|
||||
mkCncCats index [] = (index,[])
|
||||
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs)
|
||||
| id == cInt =
|
||||
let cc = pgfCncCat gr lincat fidInt
|
||||
let cc = pgfCncCat gr (i2i id) lincat fidInt
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
in (index', cc : cats)
|
||||
| id == cFloat =
|
||||
let cc = pgfCncCat gr lincat fidFloat
|
||||
let cc = pgfCncCat gr (i2i id) lincat fidFloat
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
in (index', cc : cats)
|
||||
| id == cString =
|
||||
let cc = pgfCncCat gr lincat fidString
|
||||
let cc = pgfCncCat gr (i2i id) lincat fidString
|
||||
(index',cats) = mkCncCats index cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
in (index', cc : cats)
|
||||
| otherwise =
|
||||
let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
|
||||
(index',cats) = mkCncCats (e+1) cdefs
|
||||
in (index', (i2i id,cc) : cats)
|
||||
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
|
||||
let cc@(_, _s, e, _) = pgfCncCat gr (i2i id) lincat index
|
||||
(index',cats) = mkCncCats (e+1) cdefs
|
||||
in (index', cc : cats)
|
||||
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
|
||||
|
||||
genCncFuns :: Grammar
|
||||
-> ModuleName
|
||||
-> ModuleName
|
||||
-> Array SeqId Sequence
|
||||
-> Array SeqId Sequence
|
||||
-> Array SeqId [Symbol]
|
||||
-> Array SeqId [Symbol]
|
||||
-> [(QIdent, Info)]
|
||||
-> FId
|
||||
-> Map.Map CId C.CncCat
|
||||
-> Map.Map CId (Int,Int)
|
||||
-> (FId,
|
||||
IntMap.IntMap (Set.Set C.Production),
|
||||
IntMap.IntMap [FunId],
|
||||
IntMap.IntMap [FunId],
|
||||
Array FunId C.CncFun)
|
||||
genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
|
||||
let (fid_cnt1,lindefs,linrefs,fun_st1) = mkCncCats cdefs fid_cnt IntMap.empty IntMap.empty Map.empty
|
||||
((fid_cnt2,crc,prods),fun_st2) = mkCncFuns cdefs lindefs ((fid_cnt1,Map.empty,IntMap.empty),fun_st1)
|
||||
in (fid_cnt2,prods,lindefs,linrefs,array (0,Map.size fun_st2-1) (Map.elems fun_st2))
|
||||
[(FId, [Production])],
|
||||
[(FId, [FunId])],
|
||||
[(FId, [FunId])],
|
||||
[(CId,[SeqId])])
|
||||
genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccat_ranges =
|
||||
let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty
|
||||
(fid_cnt2,funs_cnt2,funs2,prods0) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
|
||||
prods = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
|
||||
in (fid_cnt2,prods,IntMap.toList lindefs,IntMap.toList linrefs,reverse funs2)
|
||||
where
|
||||
mkCncCats [] fid_cnt lindefs linrefs fun_st =
|
||||
(fid_cnt,lindefs,linrefs,fun_st)
|
||||
mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt lindefs linrefs fun_st =
|
||||
let mseqs = case lookupModule gr m of
|
||||
Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
|
||||
_ -> ex_seqs
|
||||
(lindefs',fun_st1) = foldl' (toLinDef (m,id) funs0 mseqs) (lindefs,fun_st ) prods0
|
||||
(linrefs',fun_st2) = foldl' (toLinRef (m,id) funs0 mseqs) (linrefs,fun_st1) prods0
|
||||
in mkCncCats cdefs fid_cnt lindefs' linrefs' fun_st2
|
||||
mkCncCats (_ :cdefs) fid_cnt lindefs linrefs fun_st =
|
||||
mkCncCats cdefs fid_cnt lindefs linrefs fun_st
|
||||
mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs =
|
||||
(fid_cnt,funs_cnt,funs,lindefs,linrefs)
|
||||
mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
|
||||
let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
|
||||
in funs_cnt+(e_funid-s_funid+1)
|
||||
lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
|
||||
linrefs' = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
|
||||
funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
|
||||
in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
|
||||
mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
|
||||
mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
|
||||
|
||||
mkCncFuns [] lindefs st = st
|
||||
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) lindefs st =
|
||||
let ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
|
||||
mseqs = case lookupModule gr m of
|
||||
Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
|
||||
_ -> ex_seqs
|
||||
bundles = [([(args0,res0) | Production res0 funid0 args0 <- prods0, funid0==funid],lins) | (funid,lins) <- assocs funs0]
|
||||
!st' = foldl' (toProd id lindefs mseqs ty_C) st bundles
|
||||
in mkCncFuns cdefs lindefs st'
|
||||
mkCncFuns (_ :cdefs) lindefs st =
|
||||
mkCncFuns cdefs lindefs st
|
||||
mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods =
|
||||
(fid_cnt,funs_cnt,funs,prods)
|
||||
mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
|
||||
let ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
|
||||
!funs_cnt' = let (s_funid, e_funid) = bounds funs0
|
||||
in funs_cnt+(e_funid-s_funid+1)
|
||||
!(fid_cnt',crc',prods')
|
||||
= foldl' (toProd lindefs ty_C funs_cnt)
|
||||
(fid_cnt,crc,prods) prods0
|
||||
funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
|
||||
in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
|
||||
mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods =
|
||||
mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
|
||||
|
||||
toLinDef mid funs0 mseqs st@(lindefs,fun_st) (Production res0 funid0 [arg0])
|
||||
| arg0 == [fidVar] =
|
||||
let res = mkFId mid res0
|
||||
|
||||
lins = amap (newSeqId mseqs) (funs0 ! funid0)
|
||||
|
||||
!funid = Map.size fun_st
|
||||
!fun_st' = Map.insert ([([C.PArg [] fidVar],res)],lins) (funid, C.CncFun [] lins) fun_st
|
||||
|
||||
!lindefs' = IntMap.insertWith (++) res [funid] lindefs
|
||||
in (lindefs',fun_st')
|
||||
toLinDef res funs0 mseqs st _ = st
|
||||
|
||||
toLinRef mid funs0 mseqs st (Production res0 funid0 [arg0])
|
||||
| res0 == fidVar =
|
||||
let arg = map (mkFId mid) arg0
|
||||
|
||||
lins = amap (newSeqId mseqs) (funs0 ! funid0)
|
||||
|
||||
in foldr (\arg (linrefs,fun_st) ->
|
||||
let !funid = Map.size fun_st
|
||||
!fun_st' = Map.insert ([([C.PArg [] arg],fidVar)],lins) (funid, C.CncFun [] lins) fun_st
|
||||
|
||||
!linrefs' = IntMap.insertWith (++) arg [funid] linrefs
|
||||
in (linrefs',fun_st'))
|
||||
st arg
|
||||
toLinRef res funs0 mseqs st _ = st
|
||||
|
||||
toProd id lindefs mseqs (ctxt_C,res_C,_) (prod_st,fun_st) (sigs0,lins0) =
|
||||
let (prod_st',sigs) = mapAccumL mkCncSig prod_st sigs0
|
||||
lins = amap (newSeqId mseqs) lins0
|
||||
in addBundle id (prod_st',fun_st) (concat sigs,lins)
|
||||
toProd lindefs (ctxt_C,res_C,_) offs st (A.Production fid0 funid0 args0) =
|
||||
let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
|
||||
set0 = Set.fromList (map (PApply (offs+funid0)) (sequence args))
|
||||
fid = mkFId res_C fid0
|
||||
!prods' = case IntMap.lookup fid prods of
|
||||
Just set -> IntMap.insert fid (Set.union set0 set) prods
|
||||
Nothing -> IntMap.insert fid set0 prods
|
||||
in (fid_cnt,crc,prods')
|
||||
where
|
||||
mkCncSig prod_st (args0,res0) =
|
||||
let !(prod_st',args) = mapAccumL mkArg prod_st (zip ctxt_C args0)
|
||||
res = mkFId res_C res0
|
||||
in (prod_st',[(args,res) | args <- sequence args])
|
||||
|
||||
mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
|
||||
case fid0s of
|
||||
[fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
|
||||
[fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
|
||||
fid0s -> case Map.lookup fids crc of
|
||||
Just fid -> (st,map (flip C.PArg fid) ctxt)
|
||||
Just fid -> (st,map (flip PArg fid) ctxt)
|
||||
Nothing -> let !crc' = Map.insert fids fid_cnt crc
|
||||
!prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
|
||||
in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
|
||||
!prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
|
||||
in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
|
||||
where
|
||||
(hargs_C,arg_C) = GM.catSkeleton ty
|
||||
ctxt = mapM mkCtxt hargs_C
|
||||
ctxt = mapM (mkCtxt lindefs) hargs_C
|
||||
fids = map (mkFId arg_C) fid0s
|
||||
|
||||
mkCtxt (_,cat) =
|
||||
case Map.lookup (i2i cat) cnccats of
|
||||
Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
|
||||
Nothing -> error "GrammarToPGF.mkCtxt failed"
|
||||
mkLinDefId id = prefixIdent "lindef " id
|
||||
|
||||
newSeqId mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
|
||||
toLinDef res offs lindefs (A.Production fid0 funid0 args) =
|
||||
if args == [[fidVar]]
|
||||
then IntMap.insertWith (++) fid [offs+funid0] lindefs
|
||||
else lindefs
|
||||
where
|
||||
fid = mkFId res fid0
|
||||
|
||||
toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
|
||||
if fid0 == fidVar
|
||||
then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
|
||||
else linrefs
|
||||
where
|
||||
fids = map (mkFId res) fargs
|
||||
|
||||
mkFId (_,cat) fid0 =
|
||||
case Map.lookup (i2i cat) cnccat_ranges of
|
||||
Just (s,e) -> s+fid0
|
||||
Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
|
||||
|
||||
mkCtxt lindefs (_,cat) =
|
||||
case Map.lookup (i2i cat) cnccat_ranges of
|
||||
Just (s,e) -> [(fid,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
|
||||
Nothing -> error "GrammarToPGF.mkCtxt failed"
|
||||
|
||||
toCncFun offs (m,id) funs (funid0,lins0) =
|
||||
let mseqs = case lookupModule gr m of
|
||||
Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
|
||||
_ -> ex_seqs
|
||||
in (i2i id, map (newIndex mseqs) (elems lins0)):funs
|
||||
where
|
||||
newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
|
||||
|
||||
binSearch v arr (i,j)
|
||||
| i <= j = case compare v (arr ! k) of
|
||||
LT -> binSearch v arr (i,k-1)
|
||||
@@ -288,26 +312,9 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
|
||||
where
|
||||
k = (i+j) `div` 2
|
||||
|
||||
addBundle id ((fid_cnt,crc,prods),fun_st) bundle@(sigs,lins) =
|
||||
case Map.lookup bundle fun_st of
|
||||
Just (funid, C.CncFun funs lins) ->
|
||||
let !fun_st' = Map.insert bundle (funid, C.CncFun (i2i id:funs) lins) fun_st
|
||||
!prods' = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs
|
||||
in ((fid_cnt,crc,prods'),fun_st')
|
||||
Nothing ->
|
||||
let !funid = Map.size fun_st
|
||||
!fun_st' = Map.insert bundle (funid, C.CncFun [i2i id] lins) fun_st
|
||||
!prods' = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs
|
||||
in ((fid_cnt,crc,prods'),fun_st')
|
||||
|
||||
mkFId (_,cat) fid0 =
|
||||
case Map.lookup (i2i cat) cnccats of
|
||||
Just (C.CncCat s e _) -> s+fid0
|
||||
Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
|
||||
|
||||
|
||||
genPrintNames cdefs =
|
||||
Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
|
||||
[(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
|
||||
where
|
||||
prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
|
||||
prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
|
||||
@@ -316,7 +323,3 @@ genPrintNames cdefs =
|
||||
flatten (K s) = s
|
||||
flatten (Alts x _) = flatten x
|
||||
flatten (C x y) = flatten x +++ flatten y
|
||||
|
||||
--mkArray lst = listArray (0,length lst-1) lst
|
||||
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
|
||||
mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]
|
||||
|
||||
@@ -16,13 +16,14 @@
|
||||
|
||||
module GF.Compile.PGFtoHaskell (grammar2haskell) where
|
||||
|
||||
import PGF(showCId)
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.Option
|
||||
|
||||
import Data.List --(isPrefixOf, find, intersperse)
|
||||
import Data.List
|
||||
import Data.Maybe(mapMaybe)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Prefix = String -> String
|
||||
@@ -39,7 +40,7 @@ grammar2haskell opts name gr = foldr (++++) [] $
|
||||
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
|
||||
gId | haskellOption opts HaskellNoPrefix = id
|
||||
| otherwise = ("G"++)
|
||||
pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}","{-# LANGUAGE GADTs #-}"]
|
||||
pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"]
|
||||
| otherwise = []
|
||||
types | gadt = datatypesGADT gId lexical gr'
|
||||
| otherwise = datatypes gId lexical gr'
|
||||
@@ -262,18 +263,21 @@ fInstance gId lexical m (cat,rules) =
|
||||
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
|
||||
hSkeleton :: PGF -> (String,HSkeleton)
|
||||
hSkeleton gr =
|
||||
(showCId (absname gr),
|
||||
(showCId (abstractName gr),
|
||||
let fs =
|
||||
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
|
||||
fs@((_, (_,c)):_) <- fns]
|
||||
[(showCId c, [(showCId f, map showCId cs) | (f, cs,_) <- fs]) |
|
||||
fs@((_, _,c):_) <- fns]
|
||||
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
|
||||
)
|
||||
where
|
||||
cts = Map.keys (cats (abstract gr))
|
||||
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
|
||||
valtyps (_, (_,x)) (_, (_,y)) = compare x y
|
||||
valtypg (_, (_,x)) (_, (_,y)) = x == y
|
||||
jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
|
||||
cts = categories gr
|
||||
fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
|
||||
valtyps (_,_,x) (_,_,y) = compare x y
|
||||
valtypg (_,_,x) (_,_,y) = x == y
|
||||
jty f = case functionType gr f of
|
||||
Just ty -> let (hypos,valcat,_) = unType ty
|
||||
in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
|
||||
Nothing -> Nothing
|
||||
{-
|
||||
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
|
||||
updateSkeleton cat skel rule =
|
||||
|
||||
@@ -1,17 +1,9 @@
|
||||
module GF.Compile.PGFtoJS (pgf2js) where
|
||||
|
||||
import PGF(showCId)
|
||||
import PGF.Internal as M
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
import qualified GF.JavaScript.AbsJS as JS
|
||||
import qualified GF.JavaScript.PrintJS as JS
|
||||
|
||||
--import GF.Data.ErrM
|
||||
--import GF.Infra.Option
|
||||
|
||||
--import Control.Monad (mplus)
|
||||
--import Data.Array.Unboxed (UArray)
|
||||
import qualified Data.Array.IArray as Array
|
||||
--import Data.Maybe (fromMaybe)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@@ -21,54 +13,44 @@ pgf2js :: PGF -> String
|
||||
pgf2js pgf =
|
||||
JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
|
||||
where
|
||||
n = showCId $ absname pgf
|
||||
as = abstract pgf
|
||||
cs = Map.assocs (concretes pgf)
|
||||
start = showCId $ M.lookStartCat pgf
|
||||
n = showCId $ abstractName pgf
|
||||
start = showType [] $ startCat pgf
|
||||
grammar = new "GFGrammar" [js_abstract, js_concrete]
|
||||
js_abstract = abstract2js start as
|
||||
js_concrete = JS.EObj $ map concrete2js cs
|
||||
js_abstract = abstract2js start pgf
|
||||
js_concrete = JS.EObj $ map (concrete2js pgf) (languages pgf)
|
||||
|
||||
abstract2js :: String -> Abstr -> JS.Expr
|
||||
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
|
||||
abstract2js :: String -> PGF -> JS.Expr
|
||||
abstract2js start pgf = new "GFAbstract" [JS.EStr start, JS.EObj [absdef2js f ty | f <- functions pgf, Just ty <- [functionType pgf f]]]
|
||||
|
||||
absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
|
||||
absdef2js (f,(typ,_,_,_)) =
|
||||
let (args,cat) = M.catSkeleton typ in
|
||||
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
|
||||
absdef2js :: CId -> Type -> JS.Property
|
||||
absdef2js f typ =
|
||||
let (hypos,cat,_) = unType typ
|
||||
args = [cat | (_,_,typ) <- hypos, let (hypos,cat,_) = unType typ]
|
||||
in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
|
||||
|
||||
lit2js (LStr s) = JS.EStr s
|
||||
lit2js (LInt n) = JS.EInt n
|
||||
lit2js (LFlt d) = JS.EDbl d
|
||||
|
||||
concrete2js :: (CId,Concr) -> JS.Property
|
||||
concrete2js (c,cnc) =
|
||||
JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ cflags cnc,
|
||||
JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)],
|
||||
JS.EArray $ (map ffun2js (Array.elems (cncfuns cnc))),
|
||||
JS.EArray $ (map seq2js (Array.elems (sequences cnc))),
|
||||
JS.EObj $ map cats (Map.assocs (cnccats cnc)),
|
||||
JS.EInt (totalCats cnc)])
|
||||
where
|
||||
l = JS.IdentPropName (JS.Ident (showCId c))
|
||||
{-
|
||||
concrete2js :: PGF -> Language -> JS.Property
|
||||
concrete2js pgf lang =
|
||||
JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ concrFlags cnc,
|
||||
JS.EObj [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (concrProductions cnc cat))) | cat <- [0..concrTotalCats cnc]],
|
||||
JS.EArray [ffun2js (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc]],
|
||||
JS.EArray [seq2js (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc]],
|
||||
JS.EObj $ map cats (concrCategories cnc),
|
||||
JS.EInt (concrTotalCats cnc)])
|
||||
where
|
||||
cnc = lookConcr pgf lang
|
||||
l = JS.IdentPropName (JS.Ident (showCId lang))
|
||||
|
||||
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
|
||||
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
|
||||
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
|
||||
-}
|
||||
cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
|
||||
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
|
||||
{-
|
||||
mkStr :: String -> JS.Expr
|
||||
mkStr s = new "Str" [JS.EStr s]
|
||||
|
||||
mkSeq :: [JS.Expr] -> JS.Expr
|
||||
mkSeq [x] = x
|
||||
mkSeq xs = new "Seq" xs
|
||||
cats (c,start,end,_) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
|
||||
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
|
||||
|
||||
argIdent :: Integer -> JS.Ident
|
||||
argIdent n = JS.Ident ("x" ++ show n)
|
||||
-}
|
||||
children :: JS.Ident
|
||||
children = JS.Ident "cs"
|
||||
|
||||
@@ -78,10 +60,10 @@ frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg]
|
||||
|
||||
farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
|
||||
|
||||
ffun2js (CncFun fns lins) = new "CncFun" [JS.EArray (map (JS.EStr . showCId) fns), JS.EArray (map JS.EInt (Array.elems lins))]
|
||||
ffun2js (f,lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt lins)]
|
||||
|
||||
seq2js :: Array.Array DotPos Symbol -> JS.Expr
|
||||
seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
|
||||
seq2js :: [Symbol] -> JS.Expr
|
||||
seq2js seq = JS.EArray [sym2js s | s <- seq]
|
||||
|
||||
sym2js :: Symbol -> JS.Expr
|
||||
sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l]
|
||||
@@ -103,3 +85,4 @@ new f xs = JS.ENew (JS.Ident f) xs
|
||||
|
||||
mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
|
||||
mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]
|
||||
|
||||
|
||||
@@ -8,9 +8,8 @@
|
||||
|
||||
module GF.Compile.PGFtoProlog (grammar2prolog) where
|
||||
|
||||
import PGF(mkCId,wildCId,showCId)
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
--import PGF.Macros
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
@@ -29,70 +28,56 @@ grammar2prolog pgf
|
||||
[[plp name]] ++++
|
||||
plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)"
|
||||
[[plp name, plp cncname] |
|
||||
cncname <- Map.keys (concretes pgf)] ++++
|
||||
cncname <- languages pgf] ++++
|
||||
plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags"
|
||||
[[plp f, plp v] |
|
||||
(f, v) <- Map.assocs (gflags pgf)] ++++
|
||||
plAbstract name (abstract pgf) ++++
|
||||
unlines (map plConcrete (Map.assocs (concretes pgf)))
|
||||
(f, v) <- Map.assocs (globalFlags pgf)] ++++
|
||||
plAbstract name pgf ++++
|
||||
unlines [plConcrete name (lookConcr pgf name) | name <- languages pgf]
|
||||
)
|
||||
where name = absname pgf
|
||||
where name = abstractName pgf
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- abstract syntax
|
||||
|
||||
plAbstract :: CId -> Abstr -> String
|
||||
plAbstract name abs
|
||||
plAbstract :: CId -> PGF -> String
|
||||
plAbstract name pgf
|
||||
= (plHeader "Abstract syntax" ++++
|
||||
plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
|
||||
[[plp f, plp v] |
|
||||
(f, v) <- Map.assocs (aflags abs)] ++++
|
||||
(f, v) <- Map.assocs (abstrFlags pgf)] ++++
|
||||
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
|
||||
[[plType cat args, plHypos hypos'] |
|
||||
(cat, (hypos,_,_)) <- Map.assocs (cats abs),
|
||||
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
|
||||
let args = reverse [EFun x | (_,x) <- subst]] ++++
|
||||
[[plType cat, []] | cat <- categories pgf] ++++
|
||||
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
|
||||
[[plp fun, plType cat args, plHypos hypos] |
|
||||
(fun, (typ, _, _, _)) <- Map.assocs (funs abs),
|
||||
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
|
||||
plFacts name "def" 2 "(?Fun, ?Expr)"
|
||||
[[plp fun, plp expr] |
|
||||
(fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
|
||||
let (_, expr) = alphaConvert emptyEnv eqs]
|
||||
[[plp fun, plType cat, plHypos hypos] |
|
||||
fun <- functions pgf, Just typ <- [functionType pgf fun],
|
||||
let (hypos,cat,_) = unType typ]
|
||||
)
|
||||
where plType cat args = plTerm (plp cat) (map plp args)
|
||||
where plType cat = plTerm (plp cat) []
|
||||
plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- concrete syntax
|
||||
|
||||
plConcrete :: (CId, Concr) -> String
|
||||
plConcrete (name, cnc)
|
||||
plConcrete :: CId -> Concr -> String
|
||||
plConcrete name cnc
|
||||
= (plHeader ("Concrete syntax: " ++ plp name) ++++
|
||||
plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
|
||||
[[plp f, plp v] |
|
||||
(f, v) <- Map.assocs (cflags cnc)] ++++
|
||||
plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
|
||||
[[plp f, plp n] |
|
||||
(f, n) <- Map.assocs (printnames cnc)] ++++
|
||||
plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
|
||||
[[plCat cat, plFun fun] |
|
||||
(cat, funs) <- IntMap.assocs (lindefs cnc),
|
||||
fun <- funs] ++++
|
||||
(f, v) <- Map.assocs (concrFlags cnc)] ++++
|
||||
plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
|
||||
[[plCat cat, fun, plTerm "c" (map plCat args)] |
|
||||
(cat, set) <- IntMap.toList (productions cnc),
|
||||
(fun, args) <- map plProduction (Set.toList set)] ++++
|
||||
cat <- [0..concrTotalCats cnc-1],
|
||||
(fun, args) <- map plProduction (concrProductions cnc cat)] ++++
|
||||
plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
|
||||
[[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
|
||||
(fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
|
||||
[[plFun funid, plTerm "s" (map plSeq lins), plp absfun] |
|
||||
funid <- [0..concrTotalFuns cnc-1], let (absfun,lins) = concrFunction cnc funid] ++++
|
||||
plFacts name "seq" 2 "(?Seq, ?[Term])"
|
||||
[[plSeq seq, plp (Array.elems symbols)] |
|
||||
(seq, symbols) <- Array.assocs (sequences cnc)] ++++
|
||||
[[plSeq seqid, plp (concrSequence cnc seqid)] |
|
||||
seqid <- [0..concrTotalSeqs cnc-1]] ++++
|
||||
plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])"
|
||||
[[plp cat, plList (map plCat [start..end])] |
|
||||
(cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
|
||||
(cat,start,end,_) <- concrCategories cnc]
|
||||
)
|
||||
where plProduction (PCoerce arg) = ("-", [arg])
|
||||
plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
|
||||
@@ -101,26 +86,12 @@ plConcrete (name, cnc)
|
||||
-- prolog-printing pgf datatypes
|
||||
|
||||
instance PLPrint Type where
|
||||
plp (DTyp hypos cat args)
|
||||
| null hypos = result
|
||||
| otherwise = plOper " -> " plHypos result
|
||||
where result = plTerm (plp cat) (map plp args)
|
||||
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
|
||||
|
||||
instance PLPrint Expr where
|
||||
plp (EFun x) = plp x
|
||||
plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
|
||||
plp (EApp e e') = plOper " * " (plp e) (plp e')
|
||||
plp (ELit lit) = plp lit
|
||||
plp (EMeta n) = "Meta_" ++ show n
|
||||
|
||||
instance PLPrint Patt where
|
||||
plp (PVar x) = plp x
|
||||
plp (PApp f ps) = plOper " * " (plp f) (plp ps)
|
||||
plp (PLit lit) = plp lit
|
||||
|
||||
instance PLPrint Equation where
|
||||
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
|
||||
plp ty
|
||||
| null hypos = result
|
||||
| otherwise = plOper " -> " plHypos result
|
||||
where (hypos,cat,_) = unType ty
|
||||
result = plTerm (plp cat) []
|
||||
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
|
||||
|
||||
instance PLPrint CId where
|
||||
plp cid | isLogicalVariable str || cid == wildCId = plVar str
|
||||
@@ -213,50 +184,3 @@ isLogicalVariable = isPrefixOf logicalVariablePrefix
|
||||
|
||||
logicalVariablePrefix :: String
|
||||
logicalVariablePrefix = "X"
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- alpha convert variables to (unique) logical variables
|
||||
-- * this is needed if we want to translate variables to Prolog variables
|
||||
-- * used for abstract syntax, not concrete
|
||||
-- * not (yet?) used for variables bound in pattern equations
|
||||
|
||||
type ConvertEnv = (Int, [(CId,CId)])
|
||||
|
||||
emptyEnv :: ConvertEnv
|
||||
emptyEnv = (0, [])
|
||||
|
||||
class AlphaConvert a where
|
||||
alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
|
||||
|
||||
instance AlphaConvert a => AlphaConvert [a] where
|
||||
alphaConvert env [] = (env, [])
|
||||
alphaConvert env (a:as) = (env'', a':as')
|
||||
where (env', a') = alphaConvert env a
|
||||
(env'', as') = alphaConvert env' as
|
||||
|
||||
instance AlphaConvert Type where
|
||||
alphaConvert env@(_,subst) (DTyp hypos cat args)
|
||||
= ((ctr,subst), DTyp hypos' cat args')
|
||||
where (env', hypos') = mapAccumL alphaConvertHypo env hypos
|
||||
((ctr,_), args') = alphaConvert env' args
|
||||
|
||||
alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
|
||||
where ((ctr,subst), typ') = alphaConvert env typ
|
||||
x' = createLogicalVariable ctr
|
||||
|
||||
instance AlphaConvert Expr where
|
||||
alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
|
||||
where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
|
||||
x' = createLogicalVariable ctr
|
||||
alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
|
||||
where (env', e1') = alphaConvert env e1
|
||||
(env'', e2') = alphaConvert env' e2
|
||||
alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
|
||||
alphaConvert env expr = (env, expr)
|
||||
|
||||
-- pattern variables are not alpha converted
|
||||
-- (but they probably should be...)
|
||||
instance AlphaConvert Equation where
|
||||
alphaConvert env@(_,subst) (Equ patterns result)
|
||||
= ((ctr,subst), Equ patterns result')
|
||||
where ((ctr,_), result') = alphaConvert env result
|
||||
|
||||
@@ -9,40 +9,34 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module GF.Compile.PGFtoPython (pgf2python) where
|
||||
|
||||
import PGF(showCId)
|
||||
import PGF.Internal as M
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import qualified Data.Array.IArray as Array
|
||||
import qualified Data.Set as Set
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
--import Data.List (intersperse)
|
||||
import GF.Data.Operations
|
||||
|
||||
pgf2python :: PGF -> String
|
||||
pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
|
||||
"# This file was automatically generated by GF" +++++
|
||||
showCId name +++ "=" +++
|
||||
pyDict 1 pyStr id [
|
||||
("flags", pyDict 2 pyCId pyLiteral (Map.assocs (gflags pgf))),
|
||||
("flags", pyDict 2 pyCId pyLiteral (Map.assocs (globalFlags pgf))),
|
||||
("abstract", pyDict 2 pyStr id [
|
||||
("name", pyCId name),
|
||||
("start", pyCId start),
|
||||
("flags", pyDict 3 pyCId pyLiteral (Map.assocs (aflags abs))),
|
||||
("funs", pyDict 3 pyCId pyAbsdef (Map.assocs (funs abs)))
|
||||
("start", pyCId start),
|
||||
("flags", pyDict 3 pyCId pyLiteral (Map.assocs (abstrFlags pgf))),
|
||||
("funs", pyDict 3 pyCId pyAbsdef [(f,ty) | f <- functions pgf, Just ty <- [functionType pgf f]])
|
||||
]),
|
||||
("concretes", pyDict 2 pyCId pyConcrete (Map.assocs cncs))
|
||||
("concretes", pyDict 2 pyCId pyConcrete [(lang,lookConcr pgf lang) | lang <- languages pgf])
|
||||
] ++ "\n")
|
||||
where
|
||||
name = absname pgf
|
||||
start = M.lookStartCat pgf
|
||||
abs = abstract pgf
|
||||
cncs = concretes pgf
|
||||
name = abstractName pgf
|
||||
(_,start,_) = unType (startCat pgf)
|
||||
-- cncs = concretes pgf
|
||||
|
||||
pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
|
||||
pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
|
||||
where (args, cat) = M.catSkeleton typ
|
||||
pyAbsdef :: Type -> String
|
||||
pyAbsdef typ = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
|
||||
where (hypos,cat,_) = unType typ
|
||||
args = [cat | (_,_,typ) <- hypos, let (_,cat,_) = unType typ]
|
||||
|
||||
pyLiteral :: Literal -> String
|
||||
pyLiteral (LStr s) = pyStr s
|
||||
@@ -51,19 +45,17 @@ pyLiteral (LFlt d) = show d
|
||||
|
||||
pyConcrete :: Concr -> String
|
||||
pyConcrete cnc = pyDict 3 pyStr id [
|
||||
("flags", pyDict 0 pyCId pyLiteral (Map.assocs (cflags cnc))),
|
||||
("printnames", pyDict 4 pyCId pyStr (Map.assocs (printnames cnc))),
|
||||
("lindefs", pyDict 4 pyCat (pyList 0 pyFun) (IntMap.assocs (lindefs cnc))),
|
||||
("productions", pyDict 4 pyCat pyProds (IntMap.assocs (productions cnc))),
|
||||
("cncfuns", pyDict 4 pyFun pyCncFun (Array.assocs (cncfuns cnc))),
|
||||
("sequences", pyDict 4 pySeq pySymbols (Array.assocs (sequences cnc))),
|
||||
("cnccats", pyDict 4 pyCId pyCncCat (Map.assocs (cnccats cnc))),
|
||||
("size", show (totalCats cnc))
|
||||
("flags", pyDict 0 pyCId pyLiteral (Map.assocs (concrFlags cnc))),
|
||||
("productions", pyDict 4 pyCat pyProds [(fid,concrProductions cnc fid) | fid <- [0..concrTotalCats cnc-1]]),
|
||||
("cncfuns", pyDict 4 pyFun pyCncFun [(funid,concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]]),
|
||||
("sequences", pyDict 4 pySeq pySymbols [(seqid,concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]]),
|
||||
("cnccats", pyDict 4 pyCId pyCncCat [(cat,(s,e,lbls)) | (cat,s,e,lbls) <- concrCategories cnc]),
|
||||
("size", show (concrTotalCats cnc))
|
||||
]
|
||||
where pyProds prods = pyList 5 pyProduction (Set.toList prods)
|
||||
pyCncCat (CncCat start end _) = pyList 0 pyCat [start..end]
|
||||
pyCncFun (CncFun fns lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyList 0 pyCId fns]
|
||||
pySymbols syms = pyList 0 pySymbol (Array.elems syms)
|
||||
where pyProds prods = pyList 5 pyProduction prods
|
||||
pyCncCat (start,end,_) = pyList 0 pyCat [start..end]
|
||||
pyCncFun (f,lins) = pyTuple 0 id [pyList 0 pySeq lins, pyCId f]
|
||||
pySymbols syms = pyList 0 pySymbol syms
|
||||
|
||||
pyProduction :: Production -> String
|
||||
pyProduction (PCoerce arg) = pyTuple 0 id [pyStr "", pyList 0 pyCat [arg]]
|
||||
|
||||
@@ -2,8 +2,7 @@ module GF.Compile.ToAPI
|
||||
(stringToAPI,exprToAPI)
|
||||
where
|
||||
|
||||
import PGF.Internal
|
||||
import PGF(showCId)
|
||||
import PGF
|
||||
import Data.Maybe
|
||||
--import System.IO
|
||||
--import Control.Monad
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Infra.CheckM
|
||||
import GF.Data.Operations
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
-- | Parallel grammar compilation
|
||||
module GF.CompileInParallel(parallelBatchCompile) where
|
||||
import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
import Prelude hiding (catch)
|
||||
import Control.Monad(join,ap,when,unless)
|
||||
import Control.Applicative
|
||||
import GF.Infra.Concurrency
|
||||
@@ -34,11 +34,8 @@ import qualified Data.ByteString.Lazy as BS
|
||||
parallelBatchCompile jobs opts rootfiles0 =
|
||||
do setJobs jobs
|
||||
rootfiles <- mapM canonical rootfiles0
|
||||
lib_dirs1 <- getLibraryDirectory opts
|
||||
lib_dirs2 <- mapM canonical lib_dirs1
|
||||
let lib_dir = head lib_dirs2
|
||||
when (length lib_dirs2 >1) $ ePutStrLn ("GF_LIB_PATH defines more than one directory; using the first, " ++ show lib_dir)
|
||||
filepaths <- mapM (getPathFromFile [lib_dir] opts) rootfiles
|
||||
lib_dir <- canonical =<< getLibraryDirectory opts
|
||||
filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
|
||||
let groups = groupFiles lib_dir filepaths
|
||||
n = length groups
|
||||
when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
|
||||
|
||||
@@ -1,8 +1,7 @@
|
||||
module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
|
||||
module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
|
||||
|
||||
import PGF
|
||||
import PGF.Internal(concretes,optimizePGF,unionPGF)
|
||||
import PGF.Internal(putSplitAbs,encodeFile,runPut)
|
||||
import PGF.Internal(unionPGF,writePGF,writeConcr)
|
||||
import GF.Compile as S(batchCompile,link,srcAbsName)
|
||||
import GF.CompileInParallel as P(parallelBatchCompile)
|
||||
import GF.Compile.Export
|
||||
@@ -70,7 +69,7 @@ compileSourceFiles opts fs =
|
||||
-- in the 'Options') from the output of 'parallelBatchCompile'.
|
||||
-- If a @.pgf@ file by the same name already exists and it is newer than the
|
||||
-- source grammar files (as indicated by the 'UTCTime' argument), it is not
|
||||
-- recreated. Calls 'writePGF' and 'writeOutputs'.
|
||||
-- recreated. Calls 'writeGrammar' and 'writeOutputs'.
|
||||
linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
|
||||
do let abs = render (srcAbsName gr cnc)
|
||||
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
|
||||
@@ -80,8 +79,8 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
|
||||
if t_pgf >= Just t_src
|
||||
then putIfVerb opts $ pgfFile ++ " is up-to-date."
|
||||
else do pgfs <- mapM (link opts) cnc_grs
|
||||
let pgf = foldl1 unionPGF pgfs
|
||||
writePGF opts pgf
|
||||
let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
|
||||
writeGrammar opts pgf
|
||||
writeOutputs opts pgf
|
||||
|
||||
compileCFFiles :: Options -> [FilePath] -> IOE ()
|
||||
@@ -91,12 +90,11 @@ compileCFFiles opts fs = do
|
||||
startCat <- case rules of
|
||||
(Rule cat _ _ : _) -> return cat
|
||||
_ -> fail "empty CFG"
|
||||
let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
|
||||
probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
|
||||
let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
|
||||
unless (flag optStopAfterPhase opts == Compile) $
|
||||
do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
|
||||
let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
|
||||
writePGF opts pgf'
|
||||
writeOutputs opts pgf'
|
||||
do writeGrammar opts pgf
|
||||
writeOutputs opts pgf
|
||||
|
||||
unionPGFFiles :: Options -> [FilePath] -> IOE ()
|
||||
unionPGFFiles opts fs =
|
||||
@@ -114,12 +112,11 @@ unionPGFFiles opts fs =
|
||||
|
||||
doIt =
|
||||
do pgfs <- mapM readPGFVerbose fs
|
||||
let pgf0 = foldl1 unionPGF pgfs
|
||||
pgf = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
|
||||
let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
|
||||
pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
|
||||
if pgfFile `elem` fs
|
||||
then putStrLnE $ "Refusing to overwrite " ++ pgfFile
|
||||
else writePGF opts pgf
|
||||
else writeGrammar opts pgf
|
||||
writeOutputs opts pgf
|
||||
|
||||
readPGFVerbose f =
|
||||
@@ -136,21 +133,20 @@ writeOutputs opts pgf = do
|
||||
-- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
|
||||
-- 'link') to a @.pgf@ file.
|
||||
-- A split PGF file is output if the @-split-pgf@ option is used.
|
||||
writePGF :: Options -> PGF -> IOE ()
|
||||
writePGF opts pgf =
|
||||
writeGrammar :: Options -> PGF -> IOE ()
|
||||
writeGrammar opts pgf =
|
||||
if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
|
||||
where
|
||||
writeNormalPGF =
|
||||
do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
|
||||
writing opts outfile $ encodeFile outfile pgf
|
||||
writing opts outfile (writePGF outfile pgf)
|
||||
|
||||
writeSplitPGF =
|
||||
do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
|
||||
writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
|
||||
--encodeFile_ outfile (putSplitAbs pgf)
|
||||
forM_ (Map.toList (concretes pgf)) $ \cnc -> do
|
||||
let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
|
||||
writing opts outfile $ encodeFile outfile cnc
|
||||
writing opts outfile $ writePGF outfile pgf
|
||||
forM_ (languages pgf) $ \lang -> do
|
||||
let outfile = outputPath opts (showCId lang <.> "pgf_c")
|
||||
writing opts outfile (writeConcr outfile pgf lang)
|
||||
|
||||
|
||||
writeOutput :: Options -> FilePath-> String -> IOE ()
|
||||
|
||||
@@ -10,9 +10,9 @@
|
||||
module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
|
||||
|
||||
import Prelude hiding (catch)
|
||||
import Control.Monad
|
||||
import Control.Exception(catch,ErrorCall(..),throwIO)
|
||||
|
||||
import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
|
||||
import Data.Binary
|
||||
import qualified Data.Map as Map(empty)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
@@ -23,7 +23,7 @@ import GF.Infra.UseIO(MonadIO(..))
|
||||
import GF.Grammar.Grammar
|
||||
|
||||
import PGF() -- Binary instances
|
||||
import PGF.Internal(Literal(..))
|
||||
import PGF.Internal(Literal(..),Symbol(..))
|
||||
|
||||
-- Please change this every time when the GFO format is changed
|
||||
gfoVersion = "GF04"
|
||||
@@ -298,6 +298,53 @@ instance Binary Label where
|
||||
1 -> fmap LVar get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary BindType where
|
||||
put Explicit = putWord8 0
|
||||
put Implicit = putWord8 1
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> return Explicit
|
||||
1 -> return Implicit
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Literal where
|
||||
put (LStr s) = putWord8 0 >> put s
|
||||
put (LInt i) = putWord8 1 >> put i
|
||||
put (LFlt d) = putWord8 2 >> put d
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM LStr get
|
||||
1 -> liftM LInt get
|
||||
2 -> liftM LFlt get
|
||||
_ -> decodingError
|
||||
|
||||
instance Binary Symbol where
|
||||
put (SymCat n l) = putWord8 0 >> put (n,l)
|
||||
put (SymLit n l) = putWord8 1 >> put (n,l)
|
||||
put (SymVar n l) = putWord8 2 >> put (n,l)
|
||||
put (SymKS ts) = putWord8 3 >> put ts
|
||||
put (SymKP d vs) = putWord8 4 >> put (d,vs)
|
||||
put SymBIND = putWord8 5
|
||||
put SymSOFT_BIND = putWord8 6
|
||||
put SymNE = putWord8 7
|
||||
put SymSOFT_SPACE = putWord8 8
|
||||
put SymCAPIT = putWord8 9
|
||||
put SymALL_CAPIT = putWord8 10
|
||||
get = do tag <- getWord8
|
||||
case tag of
|
||||
0 -> liftM2 SymCat get get
|
||||
1 -> liftM2 SymLit get get
|
||||
2 -> liftM2 SymVar get get
|
||||
3 -> liftM SymKS get
|
||||
4 -> liftM2 (\d vs -> SymKP d vs) get get
|
||||
5 -> return SymBIND
|
||||
6 -> return SymSOFT_BIND
|
||||
7 -> return SymNE
|
||||
8 -> return SymSOFT_SPACE
|
||||
9 -> return SymCAPIT
|
||||
10-> return SymALL_CAPIT
|
||||
_ -> decodingError
|
||||
|
||||
--putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
|
||||
--getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
|
||||
--putGFOVersion = put gfoVersion
|
||||
|
||||
@@ -22,7 +22,6 @@ module GF.Grammar.Printer
|
||||
, ppMeta
|
||||
, getAbs
|
||||
) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
|
||||
@@ -18,7 +18,6 @@ module GF.Infra.CheckM
|
||||
checkIn, checkInModule, checkMap, checkMapRecover,
|
||||
parallelCheck, accumulateError, commitCheck,
|
||||
) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
import GF.Data.Operations
|
||||
--import GF.Infra.Ident
|
||||
|
||||
@@ -13,17 +13,17 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.Ident (-- ** Identifiers
|
||||
ModuleName(..), moduleNameS,
|
||||
Ident, ident2utf8, showIdent, prefixIdent,
|
||||
-- *** Normal identifiers (returned by the parser)
|
||||
identS, identC, identW,
|
||||
-- *** Special identifiers for internal use
|
||||
identV, identA, identAV,
|
||||
argIdent, isArgIdent, getArgIndex,
|
||||
varStr, varX, isWildIdent, varIndex,
|
||||
-- *** Raw identifiers
|
||||
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
|
||||
isPrefixOf, showRawIdent
|
||||
ModuleName(..), moduleNameS,
|
||||
Ident, ident2utf8, showIdent, prefixIdent,
|
||||
-- *** Normal identifiers (returned by the parser)
|
||||
identS, identC, identW,
|
||||
-- *** Special identifiers for internal use
|
||||
identV, identA, identAV,
|
||||
argIdent, isArgIdent, getArgIndex,
|
||||
varStr, varX, isWildIdent, varIndex,
|
||||
-- *** Raw identifiers
|
||||
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
|
||||
isPrefixOf, showRawIdent
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
@@ -31,7 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
|
||||
-- Limit use of BS functions to the ones that work correctly on
|
||||
-- UTF-8-encoded bytestrings!
|
||||
import Data.Char(isDigit)
|
||||
import PGF.Internal(Binary(..))
|
||||
import Data.Binary(Binary(..))
|
||||
import GF.Text.Pretty
|
||||
|
||||
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
-- | Source locations
|
||||
module GF.Infra.Location where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
import GF.Text.Pretty
|
||||
|
||||
-- ** Source locations
|
||||
|
||||
@@ -34,17 +34,14 @@ import Data.Maybe
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.GetOpt
|
||||
import GF.Grammar.Predef
|
||||
--import System.Console.GetOpt
|
||||
import System.FilePath
|
||||
--import System.IO
|
||||
import PGF.Internal(Literal(..))
|
||||
|
||||
import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import PGF.Internal(Literal(..))
|
||||
|
||||
usageHeader :: String
|
||||
usageHeader = unlines
|
||||
["Usage: gf [OPTIONS] [FILE [...]]",
|
||||
@@ -75,7 +72,6 @@ errors = raise . unlines
|
||||
|
||||
data Mode = ModeVersion | ModeHelp
|
||||
| ModeInteractive | ModeRun
|
||||
| ModeInteractive2 | ModeRun2
|
||||
| ModeCompiler
|
||||
| ModeServer {-port::-}Int
|
||||
deriving (Show,Eq,Ord)
|
||||
@@ -153,7 +149,7 @@ data Flags = Flags {
|
||||
optLiteralCats :: Set Ident,
|
||||
optGFODir :: Maybe FilePath,
|
||||
optOutputDir :: Maybe FilePath,
|
||||
optGFLibPath :: Maybe [FilePath],
|
||||
optGFLibPath :: Maybe FilePath,
|
||||
optDocumentRoot :: Maybe FilePath, -- For --server mode
|
||||
optRecomp :: Recomp,
|
||||
optProbsFile :: Maybe FilePath,
|
||||
@@ -208,10 +204,9 @@ parseModuleOptions args = do
|
||||
then return opts
|
||||
else errors $ map ("Non-option among module options: " ++) nonopts
|
||||
|
||||
fixRelativeLibPaths curr_dir lib_dirs (Options o) = Options (fixPathFlags . o)
|
||||
fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
|
||||
where
|
||||
fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [parent </> dir
|
||||
| parent <- curr_dir : lib_dirs]) path}
|
||||
fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
|
||||
|
||||
-- Showing options
|
||||
|
||||
@@ -307,8 +302,6 @@ optDescr =
|
||||
Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
|
||||
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
|
||||
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
|
||||
Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
|
||||
Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
|
||||
Option [] ["server"] (OptArg modeServer "port") $
|
||||
"Run in HTTP server mode on given port (default "++show defaultPort++").",
|
||||
Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
|
||||
@@ -424,7 +417,7 @@ optDescr =
|
||||
literalCat x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
|
||||
lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
|
||||
outDir x = set $ \o -> o { optOutputDir = Just x }
|
||||
gfLibPath x = set $ \o -> o { optGFLibPath = Just $ splitInModuleSearchPath x }
|
||||
gfLibPath x = set $ \o -> o { optGFLibPath = Just x }
|
||||
gfDocuRoot x = set $ \o -> o { optDocumentRoot = Just x }
|
||||
recomp x = set $ \o -> o { optRecomp = x }
|
||||
probsFile x = set $ \o -> o { optProbsFile = Just x }
|
||||
|
||||
@@ -38,7 +38,6 @@ import Control.Monad(when,liftM,foldM)
|
||||
import Control.Monad.Trans(MonadIO(..))
|
||||
import Control.Monad.State(StateT,lift)
|
||||
import Control.Exception(evaluate)
|
||||
import Data.List (nub)
|
||||
|
||||
--putIfVerb :: MonadIO io => Options -> String -> io ()
|
||||
putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
|
||||
@@ -52,32 +51,28 @@ type FullPath = String
|
||||
gfLibraryPath = "GF_LIB_PATH"
|
||||
gfGrammarPathVar = "GF_GRAMMAR_PATH"
|
||||
|
||||
getLibraryDirectory :: MonadIO io => Options -> io [FilePath]
|
||||
getLibraryDirectory :: MonadIO io => Options -> io FilePath
|
||||
getLibraryDirectory opts =
|
||||
case flag optGFLibPath opts of
|
||||
Just path -> return path
|
||||
Nothing -> liftM splitSearchPath $ liftIO (catch (getEnv gfLibraryPath)
|
||||
(\ex -> fmap (</> "lib") getDataDir))
|
||||
Nothing -> liftIO $ catch (getEnv gfLibraryPath)
|
||||
(\ex -> fmap (</> "lib") getDataDir)
|
||||
|
||||
getGrammarPath :: MonadIO io => [FilePath] -> io [FilePath]
|
||||
getGrammarPath lib_dirs = liftIO $ do
|
||||
getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
|
||||
getGrammarPath lib_dir = liftIO $ do
|
||||
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar)
|
||||
(\_ -> return $ concat [[lib_dir </> "alltenses", lib_dir </> "prelude"]
|
||||
| lib_dir <- lib_dirs ]) -- e.g. GF_GRAMMAR_PATH
|
||||
(\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
|
||||
|
||||
-- | extends the search path with the
|
||||
-- 'gfLibraryPath' and 'gfGrammarPathVar'
|
||||
-- environment variables. Returns only existing paths.
|
||||
extendPathEnv :: MonadIO io => Options -> io [FilePath]
|
||||
extendPathEnv opts = liftIO $ do
|
||||
let opt_path = nub $ flag optLibraryPath opts -- e.g. paths given as options
|
||||
lib_dirs <- getLibraryDirectory opts -- e.g. GF_LIB_PATH
|
||||
grm_path <- getGrammarPath lib_dirs -- e.g. GF_GRAMMAR_PATH
|
||||
let paths = opt_path ++ lib_dirs ++ grm_path
|
||||
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: opt_path is "++ show opt_path)
|
||||
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: lib_dirs is "++ show lib_dirs)
|
||||
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: grm_path is "++ show grm_path)
|
||||
ps <- liftM (nub . concat) $ mapM allSubdirs (nub paths)
|
||||
let opt_path = flag optLibraryPath opts -- e.g. paths given as options
|
||||
lib_dir <- getLibraryDirectory opts -- e.g. GF_LIB_PATH
|
||||
grm_path <- getGrammarPath lib_dir -- e.g. GF_GRAMMAR_PATH
|
||||
let paths = opt_path ++ [lib_dir] ++ grm_path
|
||||
ps <- liftM concat $ mapM allSubdirs paths
|
||||
mapM canonicalizePath ps
|
||||
where
|
||||
allSubdirs :: FilePath -> IO [FilePath]
|
||||
@@ -85,15 +80,11 @@ extendPathEnv opts = liftIO $ do
|
||||
allSubdirs p = case last p of
|
||||
'*' -> do let path = init p
|
||||
fs <- getSubdirs path
|
||||
let starpaths = [path </> f | f <- fs]
|
||||
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: * found "++show starpaths)
|
||||
return starpaths
|
||||
return [path </> f | f <- fs]
|
||||
_ -> do exists <- doesDirectoryExist p
|
||||
if exists
|
||||
then do
|
||||
when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: found path "++show p)
|
||||
return [p]
|
||||
else do when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: ignore path "++ show p)
|
||||
then return [p]
|
||||
else do when (verbAtLeast opts Verbose) $ putStrLn ("ignore path "++p)
|
||||
return []
|
||||
|
||||
getSubdirs :: FilePath -> IO [FilePath]
|
||||
|
||||
@@ -1,10 +1,10 @@
|
||||
{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}
|
||||
-- | GF interactive mode
|
||||
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.Importing(importSource,importGrammar)
|
||||
import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
|
||||
import GF.Command.CommonCommands(commonCommands,extend)
|
||||
import GF.Command.SourceCommands
|
||||
@@ -19,19 +19,13 @@ 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 PGF
|
||||
import PGF.Internal(abstract,funs,lookStartCat,emptyPGF)
|
||||
|
||||
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 Control.Exception(SomeException,fromException,evaluate,try)
|
||||
import Control.Monad.State hiding (void)
|
||||
@@ -289,8 +283,9 @@ importInEnv opts files =
|
||||
do let opts' = addOptions (setOptimization OptCSE False) opts
|
||||
pgf1 <- importGrammar pgf0 opts' files
|
||||
if (verbAtLeast opts Normal)
|
||||
then putStrLnFlush $
|
||||
unwords $ "\nLanguages:" : map showCId (languages pgf1)
|
||||
then case pgf1 of
|
||||
Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf)
|
||||
Nothing -> done
|
||||
else done
|
||||
return pgf1
|
||||
|
||||
@@ -301,10 +296,10 @@ tryGetLine = do
|
||||
Right l -> return l
|
||||
|
||||
prompt env
|
||||
| retain env || abs == wildCId = "> "
|
||||
| otherwise = showCId abs ++ "> "
|
||||
where
|
||||
abs = abstractName (multigrammar env)
|
||||
| retain env = "> "
|
||||
| otherwise = case multigrammar env of
|
||||
Just pgf -> showCId (abstractName pgf) ++ "> "
|
||||
Nothing -> "> "
|
||||
|
||||
type CmdEnv = (Grammar,PGFEnv)
|
||||
|
||||
@@ -318,7 +313,7 @@ data GFEnv = GFEnv {
|
||||
|
||||
emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv []
|
||||
|
||||
emptyCmdEnv = (emptyGrammar,pgfEnv emptyPGF)
|
||||
emptyCmdEnv = (emptyGrammar,pgfEnv Nothing)
|
||||
|
||||
emptyCommandEnv = mkCommandEnv allCommands
|
||||
multigrammar = pgf . snd . pgfenv
|
||||
@@ -336,17 +331,32 @@ wordCompletion gfenv (left,right) = do
|
||||
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 (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 = getCompletions state prefix
|
||||
in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
|
||||
Left (_ :: SomeException) -> ret 0 []
|
||||
-> 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
|
||||
optType opts = let readOpt str = case readType str of
|
||||
Just ty -> case checkType pgf ty of
|
||||
Left _ -> Nothing
|
||||
Right ty -> Just ty
|
||||
Nothing -> Nothing
|
||||
in maybeStrOpts "cat" (Just (startCat pgf)) readOpt opts
|
||||
(rprefix,rs) = break isSpace (reverse s0)
|
||||
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))
|
||||
_ -> ret 0 []
|
||||
Nothing -> 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]
|
||||
@@ -357,23 +367,15 @@ wordCompletion gfenv (left,right) = do
|
||||
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
|
||||
-> Haskeline.completeFilename (left,right)
|
||||
CmplIdent _ pref
|
||||
-> do mb_abs <- try (evaluate (abstract pgf))
|
||||
case mb_abs of
|
||||
Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name]
|
||||
Left (_ :: SomeException) -> ret (length pref) []
|
||||
-> case multigrammar gfenv of
|
||||
Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | cid <- functions pgf, let name = showCId cid, isPrefixOf pref name]
|
||||
Nothing -> ret (length pref) []
|
||||
_ -> ret 0 []
|
||||
where
|
||||
pgf = multigrammar gfenv
|
||||
cmdEnv = commandenv gfenv
|
||||
optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
|
||||
optType opts =
|
||||
let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
|
||||
in case readType str of
|
||||
Just ty -> ty
|
||||
Nothing -> error ("Can't parse '"++str++"' as type")
|
||||
|
||||
loop ps [] = Just ps
|
||||
loop ps (t:ts) = case nextState ps (simpleParseInput t) of
|
||||
loop ps (t:ts) = case error "nextState ps (simpleParseInput t)" of
|
||||
Left es -> Nothing
|
||||
Right ps -> loop ps ts
|
||||
|
||||
|
||||
@@ -2,10 +2,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Main where
|
||||
import GF.Compiler
|
||||
import qualified GF.Interactive as GFI1
|
||||
#ifdef C_RUNTIME
|
||||
import qualified GF.Interactive2 as GFI2
|
||||
#endif
|
||||
import GF.Interactive
|
||||
import GF.Data.ErrM
|
||||
import GF.Infra.Option
|
||||
import GF.Infra.UseIO
|
||||
@@ -47,17 +44,7 @@ mainOpts opts files =
|
||||
case flag optMode opts of
|
||||
ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
|
||||
ModeHelp -> putStrLn helpMessage
|
||||
ModeServer port -> GFI1.mainServerGFI opts port files
|
||||
ModeServer port -> mainServerGFI opts port files
|
||||
ModeCompiler -> mainGFC opts files
|
||||
ModeInteractive -> GFI1.mainGFI opts files
|
||||
ModeRun -> GFI1.mainRunGFI opts files
|
||||
#ifdef C_RUNTIME
|
||||
ModeInteractive2 -> GFI2.mainGFI opts files
|
||||
ModeRun2 -> GFI2.mainRunGFI opts files
|
||||
#else
|
||||
ModeInteractive2 -> noCruntime
|
||||
ModeRun2 -> noCruntime
|
||||
where
|
||||
noCruntime = do ePutStrLn "GF configured without C run-time support"
|
||||
exitFailure
|
||||
#endif
|
||||
ModeInteractive -> mainGFI opts files
|
||||
ModeRun -> mainRunGFI opts files
|
||||
|
||||
@@ -3,7 +3,6 @@
|
||||
module GF.Server(server) where
|
||||
import Data.List(partition,stripPrefix,isInfixOf)
|
||||
import qualified Data.Map as M
|
||||
import Control.Applicative -- for GHC<7.10
|
||||
import Control.Monad(when)
|
||||
import Control.Monad.State(StateT(..),get,gets,put)
|
||||
import Control.Monad.Error(ErrorT(..),Error(..))
|
||||
@@ -34,7 +33,7 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
|
||||
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
|
||||
import Network.CGI(handleErrors,liftIO)
|
||||
import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
|
||||
import Text.JSON(JSValue(..),Result(..),valFromObj,encode,decode,showJSON,makeObj)
|
||||
import Text.JSON(encode,showJSON,makeObj)
|
||||
--import System.IO.Silently(hCapture)
|
||||
import System.Process(readProcessWithExitCode)
|
||||
import System.Exit(ExitCode(..))
|
||||
@@ -284,17 +283,13 @@ handle logLn documentroot state0 cache execute1 stateVar
|
||||
skip_empty = filter (not.null.snd)
|
||||
|
||||
jsonList = jsonList' return
|
||||
jsonListLong ext = jsonList' (mapM (addTime ext)) ext
|
||||
jsonListLong = jsonList' (mapM addTime)
|
||||
jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext)
|
||||
|
||||
addTime ext path =
|
||||
addTime path =
|
||||
do t <- getModificationTime path
|
||||
if ext==".json"
|
||||
then addComment (time t) <$> liftIO (try $ getComment path)
|
||||
else return . makeObj $ time t
|
||||
return $ makeObj ["path".=path,"time".=format t]
|
||||
where
|
||||
addComment t = makeObj . either (const t) (\c->t++["comment".=c])
|
||||
time t = ["path".=path,"time".=format t]
|
||||
format = formatTime defaultTimeLocale rfc822DateFormat
|
||||
|
||||
rm path | takeExtension path `elem` ok_to_delete =
|
||||
@@ -336,11 +331,6 @@ handle logLn documentroot state0 cache execute1 stateVar
|
||||
do paths <- getDirectoryContents dir
|
||||
return [path | path<-paths, takeExtension path==ext]
|
||||
|
||||
getComment path =
|
||||
do Ok (JSObject obj) <- decode <$> readFile path
|
||||
Ok cmnt <- return (valFromObj "comment" obj)
|
||||
return (cmnt::String)
|
||||
|
||||
-- * Dynamic content
|
||||
|
||||
jsonresult cwd dir cmd (ecode,stdout,stderr) files =
|
||||
|
||||
@@ -7,7 +7,6 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Speech.GSL (gslPrinter) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
--import GF.Data.Utilities
|
||||
import GF.Grammar.CFG
|
||||
|
||||
@@ -11,7 +11,6 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Speech.JSGF (jsgfPrinter) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
--import GF.Data.Utilities
|
||||
import GF.Infra.Option
|
||||
|
||||
@@ -6,17 +6,13 @@
|
||||
----------------------------------------------------------------------
|
||||
module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where
|
||||
|
||||
import PGF(showCId)
|
||||
import PGF.Internal as PGF
|
||||
--import GF.Infra.Ident
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
import GF.Grammar.CFG hiding (Symbol)
|
||||
|
||||
import Data.Array.IArray as Array
|
||||
--import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
--import Data.Maybe
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@@ -31,35 +27,36 @@ type Profile = [Int]
|
||||
pgfToCFG :: PGF
|
||||
-> CId -- ^ Concrete syntax name
|
||||
-> CFG
|
||||
pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
|
||||
pgfToCFG pgf lang = mkCFG (showCId start_cat) extCats (startRules ++ concatMap ruleToCFRule rules)
|
||||
where
|
||||
(_,start_cat,_) = unType (startCat pgf)
|
||||
cnc = lookConcr pgf lang
|
||||
|
||||
rules :: [(FId,Production)]
|
||||
rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.productions cnc)
|
||||
, prod <- Set.toList set]
|
||||
rules = [(fcat,prod) | fcat <- [0..concrTotalCats cnc],
|
||||
prod <- concrProductions cnc fcat]
|
||||
|
||||
fcatCats :: Map FId Cat
|
||||
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
|
||||
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
|
||||
(fc,i) <- zip (range (s,e)) [1..]]
|
||||
| (c,s,e,lbls) <- concrCategories cnc,
|
||||
(fc,i) <- zip [s..e] [1..]]
|
||||
|
||||
fcatCat :: FId -> Cat
|
||||
fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats
|
||||
|
||||
fcatToCat :: FId -> LIndex -> Cat
|
||||
fcatToCat :: FId -> Int -> Cat
|
||||
fcatToCat c l = fcatCat c ++ row
|
||||
where row = if catLinArity c == 1 then "" else "_" ++ show l
|
||||
|
||||
-- gets the number of fields in the lincat for the given category
|
||||
catLinArity :: FId -> Int
|
||||
catLinArity c = maximum (1:[rangeSize (bounds rhs) | (CncFun _ rhs, _) <- topdownRules c])
|
||||
catLinArity c = maximum (1:[length rhs | ((_,rhs), _) <- topdownRules c])
|
||||
|
||||
topdownRules cat = f cat []
|
||||
where
|
||||
f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions cnc))
|
||||
f cat rules = foldr g rules (concrProductions cnc cat)
|
||||
|
||||
g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
|
||||
g (PApply funid args) rules = (concrFunction cnc funid,args) : rules
|
||||
g (PCoerce cat) rules = f cat rules
|
||||
|
||||
|
||||
@@ -68,28 +65,25 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
|
||||
|
||||
startRules :: [CFRule]
|
||||
startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
|
||||
| (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
|
||||
fc <- range (s,e), not (isPredefFId fc),
|
||||
| (c,s,e,lbls) <- concrCategories cnc,
|
||||
fc <- [s..e], not (isPredefFId fc),
|
||||
r <- [0..catLinArity fc-1]]
|
||||
|
||||
ruleToCFRule :: (FId,Production) -> [CFRule]
|
||||
ruleToCFRule (c,PApply funid args) =
|
||||
[Rule (fcatToCat c l) (mkRhs row) term
|
||||
| (l,seqid) <- Array.assocs rhs
|
||||
, let row = sequences cnc ! seqid
|
||||
, not (containsLiterals row)
|
||||
, f <- fns
|
||||
, let term = profilesToTerm f [fixProfile row n | n <- [0..length args-1]]
|
||||
]
|
||||
[Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
|
||||
| (l,seqid) <- zip [0..] rhs
|
||||
, let row = concrSequence cnc seqid
|
||||
, not (containsLiterals row)]
|
||||
where
|
||||
CncFun fns rhs = cncfuns cnc ! funid
|
||||
(f, rhs) = concrFunction cnc funid
|
||||
|
||||
mkRhs :: Array DotPos Symbol -> [CFSymbol]
|
||||
mkRhs = concatMap symbolToCFSymbol . Array.elems
|
||||
mkRhs :: [Symbol] -> [CFSymbol]
|
||||
mkRhs = concatMap symbolToCFSymbol
|
||||
|
||||
containsLiterals :: Array DotPos Symbol -> Bool
|
||||
containsLiterals row = not (null ([n | SymLit n _ <- Array.elems row] ++
|
||||
[n | SymVar n _ <- Array.elems row]))
|
||||
containsLiterals :: [Symbol] -> Bool
|
||||
containsLiterals row = not (null ([n | SymLit n _ <- row] ++
|
||||
[n | SymVar n _ <- row]))
|
||||
|
||||
symbolToCFSymbol :: Symbol -> [CFSymbol]
|
||||
symbolToCFSymbol (SymCat n l) = [let PArg _ fid = args!!n in NonTerminal (fcatToCat fid l)]
|
||||
@@ -105,18 +99,19 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
|
||||
symbolToCFSymbol SymALL_CAPIT = [Terminal "&|"]
|
||||
symbolToCFSymbol SymNE = []
|
||||
|
||||
fixProfile :: Array DotPos Symbol -> Int -> Profile
|
||||
fixProfile :: [Symbol] -> Int -> Profile
|
||||
fixProfile row i = [k | (k,j) <- nts, j == i]
|
||||
where
|
||||
nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
|
||||
nts = zip [0..] [j | nt <- row, j <- getPos nt]
|
||||
|
||||
getPos (SymCat j _) = [j]
|
||||
getPos (SymLit j _) = [j]
|
||||
getPos _ = []
|
||||
|
||||
profilesToTerm :: CId -> [Profile] -> CFTerm
|
||||
profilesToTerm f ps = CFObj f (zipWith profileToTerm argTypes ps)
|
||||
where (argTypes,_) = catSkeleton $ lookType (abstract pgf) f
|
||||
profilesToTerm :: [Profile] -> CFTerm
|
||||
profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)
|
||||
where Just (hypos,_,_) = fmap unType (functionType pgf f)
|
||||
argTypes = [cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]
|
||||
|
||||
profileToTerm :: CId -> Profile -> CFTerm
|
||||
profileToTerm t [] = CFMeta t
|
||||
|
||||
@@ -18,7 +18,6 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
|
||||
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
|
||||
|
||||
--import GF.Data.Utilities
|
||||
import GF.Infra.Option
|
||||
|
||||
@@ -12,7 +12,6 @@ module GF.Speech.VoiceXML (grammar2vxml) where
|
||||
import GF.Data.XML
|
||||
--import GF.Infra.Ident
|
||||
import PGF
|
||||
import PGF.Internal
|
||||
|
||||
--import Control.Monad (liftM)
|
||||
import Data.List (intersperse) -- isPrefixOf, find
|
||||
@@ -28,7 +27,7 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
|
||||
name = showCId cnc
|
||||
qs = catQuestions pgf cnc (map fst skel)
|
||||
language = languageCode pgf cnc
|
||||
start = lookStartCat pgf
|
||||
(_,start,_) = unType (startCat pgf)
|
||||
|
||||
--
|
||||
-- * VSkeleton: a simple description of the abstract syntax.
|
||||
@@ -37,8 +36,8 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
|
||||
type Skeleton = [(CId, [(CId, [CId])])]
|
||||
|
||||
pgfSkeleton :: PGF -> Skeleton
|
||||
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs])
|
||||
| (c,(_,fs,_)) <- Map.toList (cats (abstract pgf))]
|
||||
pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) | f <- functionsByCat pgf c, Just (hypos,_,_) <- [fmap unType (functionType pgf f)]])
|
||||
| c <- categories pgf]
|
||||
|
||||
--
|
||||
-- * Questions to ask
|
||||
|
||||
@@ -39,7 +39,6 @@ allTransliterations = Map.fromList [
|
||||
("amharic",transAmharic),
|
||||
("ancientgreek", transAncientGreek),
|
||||
("arabic", transArabic),
|
||||
("arabic_unvocalized", transArabicUnvoc),
|
||||
("devanagari", transDevanagari),
|
||||
("greek", transGreek),
|
||||
("hebrew", transHebrew),
|
||||
@@ -179,13 +178,6 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where
|
||||
allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
|
||||
[0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f]
|
||||
|
||||
|
||||
transArabicUnvoc :: Transliteration
|
||||
transArabicUnvoc = transArabic{
|
||||
invisible_chars = ["a","u","i","v2","o","V+","V-","a:"],
|
||||
printname = "unvocalized Arabic"
|
||||
}
|
||||
|
||||
transPersian :: Transliteration
|
||||
transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes)
|
||||
{invisible_chars = ["a","u","i"]} where
|
||||
|
||||
Reference in New Issue
Block a user