diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index ad6a9c5f2..e85d0805c 100644 --- a/src/compiler/GF/Command/Abstract.hs +++ b/src/compiler/GF/Command/Abstract.hs @@ -1,6 +1,6 @@ module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where -import PGF(CId,mkCId,Expr,showExpr) +import PGF2(Expr,showExpr) import GF.Grammar.Grammar(Term) type Ident = String @@ -31,12 +31,6 @@ data Argument | AMacro Ident deriving Show -valCIdOpts :: String -> CId -> [Option] -> CId -valCIdOpts flag def opts = - case [v | OFlag f (VId v) <- opts, f == flag] of - (v:_) -> mkCId v - _ -> def - valIntOpts :: String -> Int -> [Option] -> Int valIntOpts flag def opts = case [v | OFlag f (VInt v) <- opts, f == flag] of @@ -49,12 +43,6 @@ valStrOpts flag def opts = v:_ -> valueString v _ -> def -maybeCIdOpts :: String -> a -> (CId -> a) -> [Option] -> a -maybeCIdOpts flag def fn opts = - case [v | OFlag f (VId v) <- opts, f == flag] of - (v:_) -> fn (mkCId v) - _ -> def - maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a maybeIntOpts flag def fn opts = case [v | OFlag f (VInt v) <- opts, f == flag] of diff --git a/src/compiler/GF/Command/CommandInfo.hs b/src/compiler/GF/Command/CommandInfo.hs index 1e8d6bba1..ff863560b 100644 --- a/src/compiler/GF/Command/CommandInfo.hs +++ b/src/compiler/GF/Command/CommandInfo.hs @@ -3,7 +3,7 @@ import GF.Command.Abstract(Option,Expr,Term) import GF.Text.Pretty(render) import GF.Grammar.Printer() -- instance Pretty Term import GF.Grammar.Macros(string2term) -import PGF(mkStr,unStr,showExpr) +import PGF2(mkStr,unStr,showExpr) data CommandInfo m = CommandInfo { exec :: [Option] -> CommandArguments -> m CommandOutput, diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 83fa7e0ac..3f6251f87 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module GF.Command.Commands ( - PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands, + HasPGF(..),pgfCommands, options,flags, ) where import Prelude hiding (putStrLn) -import PGF -import PGF.Internal(writePGF) +import PGF2 +import PGF2.Internal(writePGF) import GF.Compile.Export import GF.Compile.ToAPI @@ -24,33 +24,25 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute import GF.Data.Operations --- import PGF.Internal (encodeFile) +import Data.Char import Data.List(intersperse,nub) import Data.Maybe import qualified Data.Map as Map import GF.Text.Pretty import Data.List (sort) ---import Debug.Trace +import Control.Monad(mplus) +class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF) -data PGFEnv = Env {pgf::Maybe PGF,mos::Map.Map Language Morpho} +instance (Monad m,HasPGF m) => TypeCheckArg m where + typeCheckArg e = do mb_pgf <- getPGF + case mb_pgf of + Just pgf -> either fail + (return . fst) + (inferExpr pgf e) + Nothing -> fail "Import a grammar before using this command" -pgfEnv mb_pgf = Env mb_pgf mos - where mos = case mb_pgf of - Just pgf -> Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] - Nothing -> Map.empty - -class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv - -instance (Monad m,HasPGFEnv m) => TypeCheckArg m where - typeCheckArg e = do env <- getPGFEnv - case pgf env of - Just gr -> either (fail . render . ppTcError) - (return . fst) - (inferExpr gr e) - Nothing -> fail "Import a grammar before using this command" - -pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m) +pgfCommands :: HasPGF m => Map.Map String (CommandInfo m) pgfCommands = Map.fromList [ ("aw", emptyCommandInfo { longname = "align_words", @@ -63,7 +55,7 @@ pgfCommands = Map.fromList [ "by the view flag. The target format is png, unless overridden by the", "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)." ], - exec = needPGF $ \ opts arg pgf mos -> do + exec = needPGF $ \ opts arg pgf -> do let es = toExprs arg let langs = optLangs pgf opts if isOpt "giza" opts @@ -75,7 +67,7 @@ pgfCommands = Map.fromList [ let grph = if null es then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align return $ fromString grph else do - let grphs = map (graphvizAlignment pgf langs) es + let grphs = map (graphvizWordAlignment langs graphvizDefaults) es if isFlag "view" opts || isFlag "format" opts then do let view = optViewGraph opts @@ -108,16 +100,17 @@ pgfCommands = Map.fromList [ "by the flag '-clitics'. The list of stems is given as the list of words", "of the language given by the '-lang' flag." ], - exec = needPGF $ \opts ts pgf mos -> case opts of - _ | isOpt "raw" opts -> - return . fromString . - unlines . map (unwords . map (concat . intersperse "+")) . - map (getClitics (isInMorpho (optMorpho pgf mos opts)) (optClitics opts)) . - concatMap words $ toStrings ts - _ -> - return . fromStrings . - getCliticsText (isInMorpho (optMorpho pgf mos opts)) (optClitics opts) . - concatMap words $ toStrings ts, + exec = needPGF $ \opts ts pgf -> do + concr <- optLang pgf opts + case opts of + _ | isOpt "raw" opts -> + return . fromString . + unlines . map (unwords . map (concat . intersperse "+")) . + map (getClitics (not . null . lookupMorpho concr) (optClitics opts)) . + concatMap words $ toStrings ts + _ -> return . fromStrings . + getCliticsText (not . null . lookupMorpho concr) (optClitics opts) . + concatMap words $ toStrings ts, flags = [ ("clitics","the list of possible clitics (comma-separated, no spaces)"), ("lang", "the language of analysis") @@ -151,10 +144,11 @@ pgfCommands = Map.fromList [ ("file","the file to be converted (suffix .gfe must be given)"), ("lang","the language in which to parse") ], - exec = needPGF $ \ opts _ pgf mos -> do + exec = needPGF $ \opts _ pgf -> do let file = optFile opts let printer = if (isOpt "api" opts) then exprToAPI else (showExpr []) - let conf = configureExBased pgf (optMorpho pgf mos opts) (optLang pgf opts) printer + concr <- optLang pgf opts + let conf = configureExBased pgf concr printer (file',ws) <- restricted $ parseExamplesInGrammar conf file if null ws then return () else putStrLn ("unknown words: " ++ unwords ws) return (fromString ("wrote " ++ file')), @@ -175,21 +169,19 @@ pgfCommands = Map.fromList [ explanation = unlines [ "Generates a list of random trees, by default one tree.", "If a tree argument is given, the command completes the Tree with values to", - "all metavariables in the tree. The generation can be biased by probabilities,", - "given in a file in the -probs flag." + "all metavariables in the tree. The generation can be biased by probabilities", + "if the grammar was compiled with option -probs" ], flags = [ ("cat","generation category"), ("lang","uses only functions that have linearizations in all these languages"), - ("number","number of trees generated"), - ("depth","the maximum generation depth") + ("number","number of trees generated") ], - exec = needPGF $ \ opts arg pgf mos -> do + exec = needPGF $ \opts arg pgf -> do gen <- newStdGen - let dp = valIntOpts "depth" 4 opts let ts = case mexp (toExprs arg) of - Just ex -> generateRandomFromDepth gen pgf ex (Just dp) - Nothing -> generateRandomDepth gen pgf (optType pgf opts) (Just dp) + Just ex -> generateRandomFrom gen pgf ex + Nothing -> generateRandom gen pgf (optType pgf opts) returnFromExprs $ take (optNum opts) ts }), @@ -197,29 +189,25 @@ pgfCommands = Map.fromList [ longname = "generate_trees", synopsis = "generates a list of trees, by default exhaustive", explanation = unlines [ - "Generates all trees of a given category. By default, ", - "the depth is limited to 4, but this can be changed by a flag.", + "Generates all trees of a given category.", "If a Tree argument is given, the command completes the Tree with values", "to all metavariables in the tree." ], flags = [ ("cat","the generation category"), - ("depth","the maximum generation depth"), ("lang","excludes functions that have no linearization in this language"), ("number","the number of trees generated") ], examples = [ - mkEx "gt -- all trees in the startcat, to depth 4", + mkEx "gt -- all trees in the startcat", mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP", - mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2", mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))" ], - exec = needPGF $ \opts arg pgf mos -> do - let dp = valIntOpts "depth" 4 opts + exec = needPGF $ \opts arg pgf -> do let ts = case mexp (toExprs arg) of - Just ex -> generateFromDepth pgf ex (Just dp) - Nothing -> generateAllDepth pgf (optType pgf opts) (Just dp) - returnFromExprs $ take (optNumInf opts) ts + Just ex -> generateAllFrom pgf ex + Nothing -> generateAll pgf (optType pgf opts) + returnFromExprs $ take (optNumInf opts) (map fst ts) }), ("i", emptyCommandInfo { @@ -253,22 +241,17 @@ pgfCommands = Map.fromList [ longname = "linearize", synopsis = "convert an abstract syntax expression to string", explanation = unlines [ - "Shows the linearization of a Tree by the grammars in scope.", + "Shows the linearization of a tree by the grammars in scope.", "The -lang flag can be used to restrict this to fewer languages.", "A sequence of string operations (see command ps) can be given", "as options, and works then like a pipe to the ps command, except", - "that it only affect the strings, not e.g. the table labels.", - "These can be given separately to each language with the unlexer flag", - "whose results are prepended to the other lexer flags. The value of the", - "unlexer flag is a space-separated list of comma-separated string operation", - "sequences; see example." + "that it only affect the strings, not e.g. the table labels." ], examples = [ mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor", - mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table", - mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers" + mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table" ], - exec = needPGF $ \ opts ts pgf mos -> return . fromStrings . optLins pgf opts $ toExprs ts, + exec = needPGF $ \ opts ts pgf -> return . fromStrings . optLins pgf opts $ toExprs ts, options = [ ("all", "show all forms and variants, one by line (cf. l -list)"), ("bracket","show tree structure with brackets and paths to nodes"), @@ -279,8 +262,7 @@ pgfCommands = Map.fromList [ ("treebank","show the tree and tag linearizations with language names") ] ++ stringOpOptions, flags = [ - ("lang","the languages of linearization (comma-separated, no spaces)"), - ("unlexer","set unlexers separately to each language (space-separated)") + ("lang","the languages of linearization (comma-separated, no spaces)") ] }), @@ -291,18 +273,20 @@ pgfCommands = Map.fromList [ "Prints all the analyses of space-separated words in the input string,", "using the morphological analyser of the actual grammar (see command pg)" ], - exec = needPGF $ \opts ts pgf mos -> case opts of - _ | isOpt "missing" opts -> - return . fromString . unwords . - morphoMissing (optMorpho pgf mos opts) . - concatMap words $ toStrings ts - _ | isOpt "known" opts -> - return . fromString . unwords . - morphoKnown (optMorpho pgf mos opts) . - concatMap words $ toStrings ts - _ -> return . fromString . unlines . - map prMorphoAnalysis . concatMap (morphos pgf mos opts) . - concatMap words $ toStrings ts, + exec = needPGF $ \opts ts pgf -> do + concr <- optLang pgf opts + case opts of + _ | isOpt "missing" opts -> + return . fromString . unwords . + morphoMissing concr . + concatMap words $ toStrings ts + _ | isOpt "known" opts -> + return . fromString . unwords . + morphoKnown concr . + concatMap words $ toStrings ts + _ -> return . fromString . unlines . + map prMorphoAnalysis . concatMap (morphos pgf opts) . + concatMap words $ toStrings ts, flags = [ ("lang","the languages of analysis (comma-separated, no spaces)") ], @@ -316,8 +300,8 @@ pgfCommands = Map.fromList [ longname = "morpho_quiz", synopsis = "start a morphology quiz", syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?", - exec = needPGF $ \ opts arg pgf mos -> do - let lang = optLang pgf opts + exec = needPGF $ \ opts arg pgf -> do + lang <- optLang pgf opts let typ = optType pgf opts let mt = mexp (toExprs arg) restricted $ morphologyQuiz mt pgf lang typ @@ -336,22 +320,13 @@ pgfCommands = Map.fromList [ "Shows all trees returned by parsing a string in the grammars in scope.", "The -lang flag can be used to restrict this to fewer languages.", "The default start category can be overridden by the -cat flag.", - "See also the ps command for lexing and character encoding.", - "", - "The -openclass flag is experimental and allows some robustness in ", - "the parser. For example if -openclass=\"A,N,V\" is given, the parser", - "will accept unknown adjectives, nouns and verbs with the resource grammar." + "See also the ps command for lexing and character encoding." ], - exec = needPGF $ \opts ts pgf mos -> + exec = needPGF $ \opts ts pgf -> return $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]), flags = [ ("cat","target category of parsing"), - ("lang","the languages of parsing (comma-separated, no spaces)"), - ("openclass","list of open-class categories for robust parsing"), - ("depth","maximal depth for proof search if the abstract syntax tree has meta variables") - ], - options = [ - ("bracket","prints the bracketed string from the parser") + ("lang","the languages of parsing (comma-separated, no spaces)") ] }), @@ -374,7 +349,7 @@ pgfCommands = Map.fromList [ " " ++ opt ++ "\t\t" ++ expl | ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*" ]), - exec = needPGF $ \opts _ pgf mos -> prGrammar pgf mos opts, + exec = needPGF $ \opts _ pgf -> prGrammar pgf opts, flags = [ --"cat", ("file", "set the file name when printing with -pgf option"), @@ -410,7 +385,7 @@ pgfCommands = Map.fromList [ examples = [ mkEx "pt -compute (plus one two) -- compute value" ], - exec = needPGF $ \opts arg pgf mos -> + exec = needPGF $ \opts arg pgf -> returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg, options = treeOpOptions undefined{-pgf-}, flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-} @@ -430,7 +405,7 @@ pgfCommands = Map.fromList [ ("lines","return the list of lines, instead of the singleton of all contents"), ("tree","convert strings into trees") ], - exec = needPGF $ \ opts _ pgf mos -> do + exec = needPGF $ \ opts _ pgf -> do let file = valStrOpts "file" "_gftmp" opts let exprs [] = ([],empty) exprs ((n,s):ls) | null s @@ -439,7 +414,7 @@ pgfCommands = Map.fromList [ Just e -> let (es,err) = exprs ls in case inferExpr pgf e of Right (e,t) -> (e:es,err) - Left tcerr -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err) + Left err -> (es,"on line" <+> n <> ':' $$ nest 2 err $$ err) Nothing -> let (es,err) = exprs ls in (es,"on line" <+> n <> ':' <+> "parse error" $$ err) returnFromLines ls = case exprs ls of @@ -457,38 +432,13 @@ pgfCommands = Map.fromList [ flags = [("file","the input file name")] }), - ("rt", emptyCommandInfo { - longname = "rank_trees", - synopsis = "show trees in an order of decreasing probability", - explanation = unlines [ - "Order trees from the most to the least probable, using either", - "even distribution in each category (default) or biased as specified", - "by the file given by flag -probs=FILE, where each line has the form", - "'function probability', e.g. 'youPol_Pron 0.01'." - ], - exec = needPGF $ \ opts arg pgf mos -> do - let ts = toExprs arg - let tds = rankTreesByProbs pgf ts - if isOpt "v" opts - then putStrLn $ - unlines [showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] - else return () - returnFromExprs $ map fst tds, - options = [ - ("v","show all trees with their probability scores") - ], - examples = [ - mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result" - ] - }), - ("tq", emptyCommandInfo { longname = "translation_quiz", syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?", synopsis = "start a translation quiz", - exec = needPGF $ \ opts arg pgf mos -> do - let from = optLangFlag "from" pgf opts - let to = optLangFlag "to" pgf opts + exec = needPGF $ \ opts arg pgf -> do + from <- optLangFlag "from" pgf opts + to <- optLangFlag "to" pgf opts let typ = optType pgf opts let mt = mexp (toExprs arg) restricted $ translationQuiz mt pgf from to typ @@ -522,7 +472,7 @@ pgfCommands = Map.fromList [ "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).", "See also 'vp -showdep' for another visualization of dependencies." ], - exec = needPGF $ \ opts arg pgf mos -> do + exec = needPGF $ \ opts arg pgf -> do let absname = abstractName pgf let es = toExprs arg let debug = isOpt "v" opts @@ -535,8 +485,8 @@ pgfCommands = Map.fromList [ mclab <- case cnclabels of "" -> return Nothing _ -> (Just . getCncDepLabels) `fmap` restricted (readFile cnclabels) - let lang = optLang pgf opts - let grphs = map (graphvizDependencyTree outp debug mlab mclab pgf lang) es + concr <- optLang pgf opts + let grphs = map (graphvizDependencyTree outp debug mlab mclab concr) es if isOpt "conll2latex" opts then return $ fromString $ conlls2latexDoc $ stanzas $ unlines $ toStrings arg else if isFlag "view" opts && valStrOpts "output" "" opts == "latex" @@ -582,9 +532,8 @@ pgfCommands = Map.fromList [ "by the view flag. The target format is png, unless overridden by the", "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)." ], - exec = needPGF $ \ opts arg pgf mos -> do - let es = toExprs arg - let lang = optLang pgf opts + exec = needPGF $ \opts arg pgf -> do + let es = toExprs arg let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts), noFun = isOpt "nofun" opts || not (isOpt "showfun" opts), noCat = isOpt "nocat" opts && not (isOpt "showcat" opts), @@ -597,10 +546,11 @@ pgfCommands = Map.fromList [ leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts } let depfile = valStrOpts "file" "" opts + concr <- optLang pgf opts mlab <- case depfile of "" -> return Nothing _ -> (Just . getDepLabels) `fmap` restricted (readFile depfile) - let grphs = map (graphvizParseTreeDep mlab pgf lang gvOptions) es + let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es if isFlag "view" opts || isFlag "format" opts then do let view = optViewGraph opts @@ -647,7 +597,7 @@ pgfCommands = Map.fromList [ "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).", "With option -mk, use for showing library style function names of form 'mkC'." ], - exec = needPGF $ \ opts arg pgf mos -> + exec = needPGF $ \opts arg pgf -> let es = toExprs arg in if isOpt "mk" opts then return $ fromString $ unlines $ map (tree2mk pgf) es @@ -659,7 +609,7 @@ pgfCommands = Map.fromList [ else do let funs = not (isOpt "nofun" opts) let cats = not (isOpt "nocat" opts) - let grphs = map (graphvizAbstractTree pgf (funs,cats)) es + let grphs = map (graphvizAbstractTree pgf (graphvizDefaults{noFun=funs,noCat=cats})) es if isFlag "view" opts || isFlag "format" opts then do let view = optViewGraph opts @@ -694,7 +644,7 @@ pgfCommands = Map.fromList [ "If a whole expression is given it prints the expression with refined", "metavariables and the type of the expression." ], - exec = needPGF $ \opts arg pgf mos -> do + exec = needPGF $ \opts arg pgf -> do case toExprs arg of [e] -> case unApp e of Just (id, []) -> case functionType pgf id of @@ -702,7 +652,7 @@ pgfCommands = Map.fromList [ putStrLn ("Probability: "++show (treeProbability pgf e)) return void Nothing -> case categoryContext pgf id of - Just hypos -> do putStrLn ("cat "++showCId id++if null hypos then "" else ' ':showContext [] hypos) + Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos) let ls = [showFun pgf fn ty | fn <- functionsByCat pgf id, Just ty <- [functionType pgf fn]] if null ls then return () @@ -712,7 +662,7 @@ pgfCommands = Map.fromList [ Nothing -> do putStrLn ("unknown category of function identifier "++show id) return void _ -> case inferExpr pgf e of - Left tcErr -> error $ render (ppTcError tcErr) + Left err -> error err Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e) putStrLn ("Type: "++showType [] ty) putStrLn ("Probability: "++show (treeProbability pgf e)) @@ -724,14 +674,12 @@ pgfCommands = Map.fromList [ ] where needPGF exec opts ts = do - Env mb_pgf mos <- getPGFEnv + mb_pgf <- getPGF case mb_pgf of - Just pgf -> liftSIO $ exec opts ts pgf mos + Just pgf -> liftSIO $ exec opts ts pgf _ -> fail "Import a grammar before using this command" - par pgf opts s = [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts] - where - dp = valIntOpts "depth" 4 opts + par pgf opts s = [parse concr (optType pgf opts) s | concr <- optLangs pgf opts] fromParse opts = foldr (joinPiped . fromParse1 opts) void @@ -740,49 +688,39 @@ pgfCommands = Map.fromList [ jA (Exprs es1) (Exprs es2) = Exprs (es1++es2) -- ^ fromParse1 always output Exprs - fromParse1 opts (s,(po,bs)) - | isOpt "bracket" opts = pipeMessage (showBracketedString bs) - | otherwise = + fromParse1 opts (s,po) = case po of - ParseOk ts -> fromExprs ts - ParseFailed i -> pipeMessage $ "The parser failed at token " + ParseOk ts -> fromExprs (map fst ts) + ParseFailed i _ -> pipeMessage $ "The parser failed at token " ++ show i ++": " ++ show (words s !! max 0 (i-1)) -- ++ " in " ++ show s ParseIncomplete -> pipeMessage "The sentence is not complete" - TypeError errs -> - pipeMessage . render $ - "The parsing is successful but the type checking failed with error(s):" - $$ nest 2 (vcat (map (ppTcError . snd) errs)) - optLins pgf opts ts = case opts of - _ | isOpt "groups" opts -> - concatMap snd $ groupResults - [[(lang, s) | lang <- optLangs pgf opts,s <- linear pgf opts lang t] | t <- ts] - _ -> concatMap (optLin pgf opts) ts + optLins pgf opts ts = concatMap (optLin pgf opts) ts optLin pgf opts t = case opts of _ | isOpt "treebank" opts && isOpt "chunks" opts -> - (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) : - [showCId lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts] + (abstractName pgf ++ ": " ++ showExpr [] t) : + [lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts] _ | isOpt "treebank" opts -> - (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) : - [showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t] + (abstractName pgf ++ ": " ++ showExpr [] t) : + [concreteName concr ++ ": " ++ s | concr <- optLangs pgf opts, s<-linear opts concr t] _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t - _ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t] + _ -> [s | concr <- optLangs pgf opts, s <- linear opts concr t] linChunks pgf opts t = - [(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts] + [(concreteName concr, unwords (intersperse "<+>" (map (unlines . linear opts concr) (treeChunks t)))) | concr <- optLangs pgf opts] - linear :: PGF -> [Option] -> CId -> Expr -> [String] - linear pgf opts lang = let unl = unlex opts lang in case opts of - _ | isOpt "all" opts -> concat . -- intersperse [[]] . - map (map (unl . snd)) . tabularLinearizes pgf lang + linear :: [Option] -> Concr -> Expr -> [String] + linear opts concr = case opts of + _ | isOpt "all" opts -> concat . + map (map snd) . tabularLinearizeAll concr _ | isOpt "list" opts -> (:[]) . commaList . concat . - map (map (unl . snd)) . tabularLinearizes pgf lang - _ | isOpt "table" opts -> concat . -- intersperse [[]] . - map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang - _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize pgf lang - _ -> (:[]) . unl . linearize pgf lang + map (map snd) . tabularLinearizeAll concr + _ | isOpt "table" opts -> concat . + map (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr + _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr + _ -> (:[]) . linearize concr -- replace each non-atomic constructor with mkC, where C is the val cat tree2mk pgf = showExpr [] . t2m where @@ -791,61 +729,38 @@ pgfCommands = Map.fromList [ _ -> t mk f = case functionType pgf f of Just ty -> let (_,cat,_) = unType ty - in mkCId ("mk" ++ showCId cat) + in "mk" ++ cat Nothing -> f - unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- - - getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of - lexs -> case lookup lang - [(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of - Just le -> chunks ',' le - _ -> [] - commaList [] = [] commaList ws = concat $ head ws : map (", " ++) (tail ws) --- Proposed logic of coding in unlexing: --- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used. --- - If lang has flag coding=utf8, -to_utf8 is ignored. --- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first. --- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly -{- - unlexx pgf opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ---- - optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of - Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts - Just (LStr other) | isOpt "to_utf8" opts -> - let cod = ("from_" ++ other) - in cod : filter (/=cod) (map prOpt opts) - _ -> map prOpt opts --} - optLang = optLangFlag "lang" optLangs = optLangsFlag "lang" - optLangsFlag f pgf opts = case valStrOpts f "" opts of - "" -> languages pgf - lang -> map (completeLang pgf) (chunks ',' lang) - completeLang pgf la = let cla = (mkCId la) in - if elem cla (languages pgf) - then cla - else (mkCId (showCId (abstractName pgf) ++ la)) + optLangFlag flag pgf opts = + case optLangsFlag flag pgf opts of + [] -> fail "no language specified" + (l:ls) -> return l + + optLangsFlag flag pgf opts = + case valStrOpts flag "" opts of + "" -> Map.elems langs + str -> mapMaybe (completeLang pgf) (chunks ',' str) + where + langs = languages pgf + + completeLang pgf la = + mplus (Map.lookup la langs) + (Map.lookup (abstractName pgf ++ la) langs) - optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId] -{- - optProbs opts pgf = case valStrOpts "probs" "" opts of - "" -> return pgf - file -> do - probs <- restricted $ readProbabilitiesFromFile file pgf - return (setProbabilities probs pgf) --} optFile opts = valStrOpts "file" "_gftmp" opts optType pgf opts = let readOpt str = case readType str of Just ty -> case checkType pgf ty of - Left tcErr -> error $ render (ppTcError tcErr) - Right ty -> ty + Left err -> error err + Right ty -> ty Nothing -> error ("Can't parse '"++str++"' as a type") in maybeStrOpts "cat" (startCat pgf) readOpt opts optViewFormat opts = valStrOpts "format" "png" opts @@ -858,35 +773,31 @@ pgfCommands = Map.fromList [ [] -> pipeMessage "no trees found" _ -> fromExprs es - prGrammar pgf mos opts + prGrammar pgf opts | isOpt "pgf" opts = do - let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts + let outfile = valStrOpts "file" (abstractName pgf ++ ".pgf") opts restricted $ writePGF outfile pgf putStrLn $ "wrote file " ++ outfile return void - | isOpt "cats" opts = return $ fromString $ unwords $ map showCId $ categories pgf + | isOpt "cats" opts = return $ fromString $ unwords $ categories pgf | isOpt "funs" opts = return $ fromString $ unlines [showFun pgf f ty | f <- functions pgf, Just ty <- [functionType pgf f]] - | isOpt "fullform" opts = return $ fromString $ concatMap (morpho mos "" prFullFormLexicon) $ optLangs pgf opts - | isOpt "langs" opts = return $ fromString $ unwords $ map showCId $ languages pgf + | isOpt "fullform" opts = return $ fromString $ concatMap prFullFormLexicon $ optLangs pgf opts + | isOpt "langs" opts = return $ fromString $ unwords $ Map.keys $ languages pgf - | isOpt "lexc" opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts - | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":":[showCId f | f <- functions pgf, not (hasLinearization pgf la f)]) | - la <- optLangs pgf opts] - | isOpt "words" opts = return $ fromString $ concatMap (morpho mos "" prAllWords) $ optLangs pgf opts + | isOpt "lexc" opts = return $ fromString $ concatMap prLexcLexicon $ optLangs pgf opts + | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (concreteName concr:":":[f | f <- functions pgf, not (hasLinearization concr f)]) | + concr <- optLangs pgf opts] + | isOpt "words" opts = return $ fromString $ concatMap prAllWords $ optLangs pgf opts | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf - showFun pgf id ty = kwd++" "++showCId id ++ " : " ++ showType [] ty + showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty where kwd | functionIsDataCon pgf id = "data" | otherwise = "fun" - morphos pgf mos opts s = - [(s,morpho mos [] (\mo -> lookupMorpho mo s) la) | la <- optLangs pgf opts] - - morpho mos z f la = maybe z f $ Map.lookup la mos - - optMorpho pgf mos opts = morpho mos (error "no morpho") id (head (optLangs pgf opts)) + morphos pgf opts s = + [(s,lookupMorpho concr s) | concr <- optLangs pgf opts] optClitics opts = case valStrOpts "clitics" "" opts of "" -> [] @@ -899,18 +810,28 @@ pgfCommands = Map.fromList [ -- ps -f -g s returns g (f s) treeOps pgf opts s = foldr app s (reverse opts) where app (OOpt op) | Just (Left f) <- treeOp pgf op = f - app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x) + app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x app _ = id +morphoMissing :: Concr -> [String] -> [String] +morphoMissing = morphoClassify False + +morphoKnown :: Concr -> [String] -> [String] +morphoKnown = morphoClassify True + +morphoClassify :: Bool -> Concr -> [String] -> [String] +morphoClassify k concr ws = [w | w <- ws, k /= null (lookupMorpho concr w), notLiteral w] where + notLiteral w = not (all isDigit w) + treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] -translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO () +translationQuiz :: Maybe Expr -> PGF -> Concr -> Concr -> Type -> IO () translationQuiz mex pgf ig og typ = do tts <- translationList mex pgf ig og typ infinity mkQuiz "Welcome to GF Translation Quiz." tts -morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO () +morphologyQuiz :: Maybe Expr -> PGF -> Concr -> Type -> IO () morphologyQuiz mex pgf ig typ = do tts <- morphologyList mex pgf ig typ infinity mkQuiz "Welcome to GF Morphology Quiz." tts @@ -919,28 +840,28 @@ morphologyQuiz mex pgf ig typ = do infinity :: Int infinity = 256 -prLexcLexicon :: Morpho -> String -prLexcLexicon mo = - unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"] +prLexcLexicon :: Concr -> String +prLexcLexicon concr = + unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"] where - morpho = fullFormLexicon mo - prLexc l p = showCId l ++ concat (mkTags (words p)) + morpho = fullFormLexicon concr + prLexc l p = l ++ concat (mkTags (words p)) mkTags p = case p of "s":ws -> mkTags ws --- remove record field ws -> map ('+':) ws - multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p) <- lps] + multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps] -prFullFormLexicon :: Morpho -> String -prFullFormLexicon mo = - unlines (map prMorphoAnalysis (fullFormLexicon mo)) +prFullFormLexicon :: Concr -> String +prFullFormLexicon concr = + unlines (map prMorphoAnalysis (fullFormLexicon concr)) -prAllWords :: Morpho -> String -prAllWords mo = - unwords [w | (w,_) <- fullFormLexicon mo] +prAllWords :: Concr -> String +prAllWords concr = + unwords [w | (w,_) <- fullFormLexicon concr] prMorphoAnalysis (w,lps) = - unlines (w:[showCId l ++ " : " ++ p | (l,p) <- lps]) + unlines (w:[l ++ " : " ++ p ++ show prob | (l,p,prob) <- lps]) viewGraphviz :: String -> String -> String -> [String] -> SIO CommandOutput viewGraphviz view format name grphs = do diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs deleted file mode 100644 index 08caf705d..000000000 --- a/src/compiler/GF/Command/Commands2.hs +++ /dev/null @@ -1,822 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} -module GF.Command.Commands2 ( - PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands, - options, flags, - ) where -import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint - -import PGF2 -import qualified PGF as H -import GF.Compile.ToAPI(exprToAPI) -import GF.Infra.UseIO(writeUTF8File) -import GF.Infra.SIO(MonadSIO,liftSIO,putStrLn,restricted,restrictedSystem) -import GF.Command.Abstract -import GF.Command.CommandInfo -import GF.Data.Operations -import Data.List(intersperse,intersect,nub,sortBy) -import Data.Maybe -import qualified Data.Map as Map -import GF.Text.Pretty -import Control.Monad(mplus) - - -data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr} - -pgfEnv pgf = Env (Just pgf) (languages pgf) -emptyPGFEnv = Env Nothing Map.empty - -class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv - -instance (Monad m,HasPGFEnv m) => TypeCheckArg m where - typeCheckArg e = do env <- getPGFEnv - case pgf env of - Just gr -> either fail - (return . hsExpr . fst) - (inferExpr gr (cExpr e)) - Nothing -> fail "Import a grammar before using this command" - -pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m) -pgfCommands = Map.fromList [ - ("aw", emptyCommandInfo { - longname = "align_words", - synopsis = "show word alignments between languages graphically", - explanation = unlines [ - "Prints a set of strings in the .dot format (the graphviz format).", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is postscript, unless overridden by the", - "flag -format." - ], - exec = needPGF $ \opts es env -> do - let cncs = optConcs env opts - if isOpt "giza" opts - then if length cncs == 2 - then let giz = map (gizaAlignment pgf (snd (cncs !! 0)) (snd (cncs !! 1)) . cExpr) (toExprs es) - lsrc = unlines $ map (\(x,_,_) -> x) giz - ltrg = unlines $ map (\(_,x,_) -> x) giz - align = unlines $ map (\(_,_,x) -> x) giz - grph = if null (toExprs es) then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align - in return (fromString grph) - else error "For giza alignment you need exactly two languages" - else let gvOptions=graphvizDefaults{leafFont = valStrOpts "font" "" opts, - leafColor = valStrOpts "color" "" opts, - leafEdgeStyle = valStrOpts "edgestyle" "" opts - } - grph = if null (toExprs es) then [] else graphvizWordAlignment (map snd cncs) gvOptions (cExpr (head (toExprs es))) - in if isFlag "view" opts || isFlag "format" opts - then do let file s = "_grph." ++ s - let view = optViewGraph opts - let format = optViewFormat opts - restricted $ writeUTF8File (file "dot") grph - restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format - restrictedSystem $ view ++ " " ++ file format - return void - else return (fromString grph), - examples = [ - ("gr | aw" , "generate a tree and show word alignment as graph script"), - ("gr | aw -view=\"open\"" , "generate a tree and display alignment on Mac"), - ("gr | aw -view=\"eog\"" , "generate a tree and display alignment on Ubuntu"), - ("gt | aw -giza | wf -file=aligns" , "generate trees, send giza alignments to file") - ], - options = [ - ("giza", "show alignments in the Giza format; the first two languages") - ], - flags = [ - ("format","format of the visualization file (default \"png\")"), - ("lang", "alignments for this list of languages (default: all)"), - ("view", "program to open the resulting file"), - ("font", "font for the words"), - ("color", "color for the words"), - ("edgestyle", "the style for links between words") - ] - }), -{- - ("eb", emptyCommandInfo { - longname = "example_based", - syntax = "eb (-probs=FILE | -lang=LANG)* -file=FILE.gfe", - synopsis = "converts .gfe files to .gf files by parsing examples to trees", - explanation = unlines [ - "Reads FILE.gfe and writes FILE.gf. Each expression of form", - "'%ex CAT QUOTEDSTRING' in FILE.gfe is replaced by a syntax tree.", - "This tree is the first one returned by the parser; a biased ranking", - "can be used to regulate the order. If there are more than one parses", - "the rest are shown in comments, with probabilities if the order is biased.", - "The probabilities flag and configuration file is similar to the commands", - "gr and rt. Notice that the command doesn't change the environment,", - "but the resulting .gf file must be imported separately." - ], - options = [ - ("api","convert trees to overloaded API expressions (using Syntax not Lang)") - ], - flags = [ - ("file","the file to be converted (suffix .gfe must be given)"), - ("lang","the language in which to parse"), - ("probs","file with probabilities to rank the parses") - ], - exec = \env@(pgf, mos) opts _ -> do - let file = optFile opts - pgf <- optProbs opts pgf - let printer = if (isOpt "api" opts) then exprToAPI else (H.showExpr []) - let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer - (file',ws) <- restricted $ parseExamplesInGrammar conf file - if null ws then return () else putStrLn ("unknown words: " ++ unwords ws) - return (fromString ("wrote " ++ file')), - needsTypeCheck = False - }), --} -{- - ("gr", emptyCommandInfo { - longname = "generate_random", - synopsis = "generate random trees in the current abstract syntax", - syntax = "gr [-cat=CAT] [-number=INT]", - examples = [ - mkEx "gr -- one tree in the startcat of the current grammar", - mkEx "gr -cat=NP -number=16 -- 16 trees in the category NP", - mkEx "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha", - mkEx "gr -probs=FILE -- generate with bias", - mkEx "gr (AdjCN ? (UseN ?)) -- generate trees of form (AdjCN ? (UseN ?))" - ], - explanation = unlines [ - "Generates a list of random trees, by default one tree.", - "If a tree argument is given, the command completes the Tree with values to", - "all metavariables in the tree. The generation can be biased by probabilities,", - "given in a file in the -probs flag." - ], - flags = [ - ("cat","generation category"), - ("lang","uses only functions that have linearizations in all these languages"), - ("number","number of trees generated"), - ("depth","the maximum generation depth"), - ("probs", "file with biased probabilities (format 'f 0.4' one by line)") - ], - exec = \env@(pgf, mos) opts xs -> do - pgf <- optProbs opts (optRestricted opts pgf) - gen <- newStdGen - let dp = valIntOpts "depth" 4 opts - let ts = case mexp xs of - Just ex -> H.generateRandomFromDepth gen pgf ex (Just dp) - Nothing -> H.generateRandomDepth gen pgf (optType pgf opts) (Just dp) - returnFromExprs $ take (optNum opts) ts - }), --} - ("gt", emptyCommandInfo { - longname = "generate_trees", - synopsis = "generates a list of trees, by default exhaustive", - flags = [("cat","the generation category"), - ("number","the number of trees generated")], - examples = [ - mkEx "gt -- all trees in the startcat", - mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP"], - exec = needPGF $ \ opts _ env@(pgf,_) -> - let ts = map fst (generateAll pgf cat) - cat = optType pgf opts - in returnFromCExprs (takeOptNum opts ts), - needsTypeCheck = False - }), - ("i", emptyCommandInfo { - longname = "import", - synopsis = "import a grammar from a compiled .pgf file", - explanation = unlines [ - "Reads a grammar from a compiled .pgf file.", - "Old modules are discarded.", -{- - "The grammar parser depends on the file name suffix:", - - " .cf context-free (labelled BNF) source", - " .ebnf extended BNF source", - " .gfm multi-module GF source", - " .gf normal GF source", - " .gfo compiled GF source", --} - " .pgf precompiled grammar in Portable Grammar Format" - ], - flags = [ --- ("probs","file with biased probabilities for generation") - ], - options = [ - -- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"] --- ("retain","retain operations (used for cc command)"), --- ("src", "force compilation from source"), --- ("v", "be verbose - show intermediate status information") - ], - needsTypeCheck = False - }), - ("l", emptyCommandInfo { - longname = "linearize", - synopsis = "convert an abstract syntax expression to string", - explanation = unlines [ - "Shows the linearization of a Tree by the grammars in scope.", - "The -lang flag can be used to restrict this to fewer languages.", - "A sequence of string operations (see command ps) can be given", - "as options, and works then like a pipe to the ps command, except", - "that it only affect the strings, not e.g. the table labels.", - "These can be given separately to each language with the unlexer flag", - "whose results are prepended to the other lexer flags. The value of the", - "unlexer flag is a space-separated list of comma-separated string operation", - "sequences; see example." - ], - examples = [ - mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize a tree to LangSwe and LangNor", - mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table", - mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers" - ], - exec = needPGF $ \ opts arg env -> - return . fromStrings . optLins env opts . map cExpr $ toExprs arg, - options = [ - ("all", "show all forms and variants, one by line (cf. l -list)"), - ("bracket","show tree structure with brackets and paths to nodes"), - ("groups", "all languages, grouped by lang, remove duplicate strings"), - ("list","show all forms and variants, comma-separated on one line (cf. l -all)"), - ("multi","linearize to all languages (default)"), - ("table","show all forms labelled by parameters"), - ("treebank","show the tree and tag linearizations with language names") - ], - flags = [ - ("lang","the languages of linearization (comma-separated, no spaces)") - ] - }), - ("ma", emptyCommandInfo { - longname = "morpho_analyse", - synopsis = "print the morphological analyses of the (multiword) expression in the string", - explanation = unlines [ - "Prints all the analyses of the (multiword) expression in the input string,", - "using the morphological analyser of the actual grammar (see command pg)" - ], - exec = needPGF $ \opts args env -> - return ((fromString . unlines . - map prMorphoAnalysis . concatMap (morphos env opts) . toStrings) args), - flags = [ - ("lang","the languages of analysis (comma-separated, no spaces)") - ] - }), -{- - ("mq", emptyCommandInfo { - longname = "morpho_quiz", - synopsis = "start a morphology quiz", - syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?", - exec = \env@(pgf, mos) opts xs -> do - let lang = optLang pgf opts - let typ = optType pgf opts - pgf <- optProbs opts pgf - let mt = mexp xs - restricted $ morphologyQuiz mt pgf lang typ - return void, - flags = [ - ("lang","language of the quiz"), - ("cat","category of the quiz"), - ("number","maximum number of questions"), - ("probs","file with biased probabilities for generation") - ] - }), --} - ("p", emptyCommandInfo { - longname = "parse", - synopsis = "parse a string to abstract syntax expression", - explanation = unlines [ - "Shows all trees returned by parsing a string in the grammars in scope.", - "The -lang flag can be used to restrict this to fewer languages.", - "The default start category can be overridden by the -cat flag.", - "See also the ps command for lexing and character encoding." - ], - flags = [ - ("cat","target category of parsing"), - ("lang","the languages of parsing (comma-separated, no spaces)"), - ("number","maximum number of trees returned") - ], - examples = [ - mkEx "p \"this fish is fresh\" | l -lang=Swe -- try parsing with all languages and translate the successful parses to Swedish" - ], - exec = needPGF $ \ opts ts env -> return . cParse env opts $ toStrings ts - }), - ("pg", emptyCommandInfo { - longname = "print_grammar", - synopsis = "prints different information about the grammar", - exec = needPGF $ \opts _ env -> prGrammar env opts, - options = [ - ("cats", "show just the names of abstract syntax categories"), - ("fullform", "print the fullform lexicon"), - ("funs", "show just the names and types of abstract syntax functions"), - ("langs", "show just the names of top concrete syntax modules"), - ("lexc", "print the lexicon in Xerox LEXC format"), - ("missing","show just the names of functions that have no linearization"), - ("words", "print the list of words") - ], - flags = [ - ("lang","the languages that need to be printed") - ], - examples = [ - mkEx "pg -langs -- show the names of top concrete syntax modules", - mkEx "pg -funs | ? grep \" S ;\" -- show functions with value cat S" - ] - }), - -{- - ("pt", emptyCommandInfo { - longname = "put_tree", - syntax = "pt OPT? TREE", - synopsis = "return a tree, possibly processed with a function", - explanation = unlines [ - "Returns a tree obtained from its argument tree by applying", - "tree processing functions in the order given in the command line", - "option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors", - "are type checking and semantic computation." - ], - examples = [ - mkEx "pt -compute (plus one two) -- compute value", - mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..." - ], - exec = \env@(pgf, mos) opts -> - returnFromExprs . takeOptNum opts . treeOps pgf opts, - options = treeOpOptions undefined{-pgf-}, - flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-} - }), --} - ("rf", emptyCommandInfo { - longname = "read_file", - synopsis = "read string or tree input from a file", - explanation = unlines [ - "Reads input from file. The filename must be in double quotes.", - "The input is interpreted as a string by default, and can hence be", - "piped e.g. to the parse command. The option -tree interprets the", - "input as a tree, which can be given e.g. to the linearize command.", - "The option -lines will result in a list of strings or trees, one by line." - ], - options = [ - ("lines","return the list of lines, instead of the singleton of all contents"), - ("tree","convert strings into trees") - ], - exec = needPGF $ \opts _ env@(pgf, mos) -> do - let file = optFile opts - let exprs [] = ([],empty) - exprs ((n,s):ls) | null s - = exprs ls - exprs ((n,s):ls) = case readExpr s of - Just e -> let (es,err) = exprs ls - in case inferExpr pgf e of - Right (e,t) -> (e:es,err) - Left msg -> (es,"on line" <+> n <> ':' $$ msg $$ err) - Nothing -> let (es,err) = exprs ls - in (es,"on line" <+> n <> ':' <+> "parse error" $$ err) - returnFromLines ls = case exprs ls of - (es, err) | null es -> return $ pipeMessage $ render (err $$ "no trees found") - | otherwise -> return $ pipeWithMessage (map hsExpr es) (render err) - - s <- restricted $ readFile file - case opts of - _ | isOpt "lines" opts && isOpt "tree" opts -> - returnFromLines (zip [1::Int ..] (lines s)) - _ | isOpt "tree" opts -> - returnFromLines [(1::Int,s)] - _ | isOpt "lines" opts -> return (fromStrings $ lines s) - _ -> return (fromString s), - flags = [("file","the input file name")] - }), - ("rt", emptyCommandInfo { - longname = "rank_trees", - synopsis = "show trees in an order of decreasing probability", - explanation = unlines [ - "Order trees from the most to the least probable, using either", - "even distribution in each category (default) or biased as specified", - "by the file given by flag -probs=FILE, where each line has the form", - "'function probability', e.g. 'youPol_Pron 0.01'." - ], - exec = needPGF $ \opts es env@(pgf, _) -> do - let tds = sortBy (\(_,p) (_,q) -> compare p q) - [(t, treeProbability pgf t) | t <- map cExpr (toExprs es)] - if isOpt "v" opts - then putStrLn $ - unlines [PGF2.showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] - else return () - returnFromExprs $ map (hsExpr . fst) tds, - flags = [ - ("probs","probabilities from this file (format 'f 0.6' per line)") - ], - options = [ - ("v","show all trees with their probability scores") - ], - examples = [ - mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result" - ] - }), -{- - ("tq", emptyCommandInfo { - longname = "translation_quiz", - syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?", - synopsis = "start a translation quiz", - exec = \env@(pgf, mos) opts xs -> do - let from = optLangFlag "from" pgf opts - let to = optLangFlag "to" pgf opts - let typ = optType pgf opts - let mt = mexp xs - pgf <- optProbs opts pgf - restricted $ translationQuiz mt pgf from to typ - return void, - flags = [ - ("from","translate from this language"), - ("to","translate to this language"), - ("cat","translate in this category"), - ("number","the maximum number of questions"), - ("probs","file with biased probabilities for generation") - ], - examples = [ - mkEx ("tq -from=Eng -to=Swe -- any trees in startcat"), - mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form") - ] - }), - ("vd", emptyCommandInfo { - longname = "visualize_dependency", - synopsis = "show word dependency tree graphically", - explanation = unlines [ - "Prints a dependency tree in the .dot format (the graphviz format, default)", - "or the CoNLL/MaltParser format (flag -output=conll for training, malt_input", - "for unanalysed input).", - "By default, the last argument is the head of every abstract syntax", - "function; moreover, the head depends on the head of the function above.", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is png, unless overridden by the", - "flag -format." - ], - exec = \env@(pgf, mos) opts es -> do - let debug = isOpt "v" opts - let file = valStrOpts "file" "" opts - let outp = valStrOpts "output" "dot" opts - mlab <- case file of - "" -> return Nothing - _ -> (Just . H.getDepLabels . lines) `fmap` restricted (readFile file) - let lang = optLang pgf opts - let grphs = unlines $ map (H.graphvizDependencyTree outp debug mlab Nothing pgf lang) es - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grphd." ++ s - let view = optViewGraph opts - let format = optViewFormat opts - restricted $ writeUTF8File (file "dot") grphs - restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format - restrictedSystem $ view ++ " " ++ file format - return void - else return $ fromString grphs, - examples = [ - mkEx "gr | vd -- generate a tree and show dependency tree in .dot", - mkEx "gr | vd -view=open -- generate a tree and display dependency tree on a Mac", - mkEx "gr -number=1000 | vd -file=dep.labels -output=malt -- generate training treebank", - mkEx "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences" - ], - options = [ - ("v","show extra information") - ], - flags = [ - ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"), - ("format","format of the visualization file (default \"png\")"), - ("output","output format of graph source (default \"dot\")"), - ("view","program to open the resulting file (default \"open\")"), - ("lang","the language of analysis") - ] - }), --} - - ("vp", emptyCommandInfo { - longname = "visualize_parse", - synopsis = "show parse tree graphically", - explanation = unlines [ - "Prints a parse tree in the .dot format (the graphviz format).", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is png, unless overridden by the", - "flag -format." - ], - exec = needPGF $ \opts arg env@(pgf, concs) -> - do let es = toExprs arg - let concs = optConcs env opts - - let gvOptions=graphvizDefaults{noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts), - noFun = isOpt "nofun" opts || not (isOpt "showfun" opts), - noCat = isOpt "nocat" opts && not (isOpt "showcat" opts), - nodeFont = valStrOpts "nodefont" "" opts, - leafFont = valStrOpts "leaffont" "" opts, - nodeColor = valStrOpts "nodecolor" "" opts, - leafColor = valStrOpts "leafcolor" "" opts, - nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts, - leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts - } - - let grph= if null es || null concs - then [] - else graphvizParseTree (snd (head concs)) gvOptions (cExpr (head es)) - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grph." ++ s - let view = optViewGraph opts - let format = optViewFormat opts - restricted $ writeUTF8File (file "dot") grph - restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format - restrictedSystem $ view ++ " " ++ file format - return void - else return $ fromString grph, - examples = [ - mkEx "p -lang=Eng \"John walks\" | vp -- generate a tree and show parse tree as .dot script", - mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac" - ], - options = [ - ("showcat","show categories in the tree nodes (default)"), - ("nocat","don't show categories"), - ("showfun","show function names in the tree nodes"), - ("nofun","don't show function names (default)"), - ("showleaves","show the leaves of the tree (default)"), - ("noleaves","don't show the leaves of the tree (i.e., only the abstract tree)") - ], - flags = [ - ("lang","the language to visualize"), - ("format","format of the visualization file (default \"png\")"), - ("view","program to open the resulting file (default \"open\")"), - ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"), - ("leaffont","font for tree leaves (default: nodefont)"), - ("nodecolor","color for tree nodes (default: black -- graphviz standard color)"), - ("leafcolor","color for tree leaves (default: nodecolor)"), - ("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)"), - ("leafedgestyle","edge style for links to leaves (solid/dashed/dotted/bold, default: dashed)") - ] - }), - - ("vt", emptyCommandInfo { - longname = "visualize_tree", - synopsis = "show a set of trees graphically", - explanation = unlines [ - "Prints a set of trees in the .dot format (the graphviz format).", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is postscript, unless overridden by the", - "flag -format." - ], - exec = needPGF $ \opts arg env@(pgf, _) -> - let es = toExprs arg in - if isOpt "api" opts - then do - mapM_ (putStrLn . exprToAPI) es - return void - else do - let gvOptions=graphvizDefaults{noFun = isOpt "nofun" opts, - noCat = isOpt "nocat" opts, - nodeFont = valStrOpts "nodefont" "" opts, - nodeColor = valStrOpts "nodecolor" "" opts, - nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts - } - let grph = unlines (map (graphvizAbstractTree pgf gvOptions . cExpr) es) - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grph." ++ s - let view = optViewGraph opts - let format = optViewFormat opts - restricted $ writeUTF8File (file "dot") grph - restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format - restrictedSystem $ view ++ " " ++ file format - return void - else return $ fromString grph, - examples = [ - mkEx "p \"hello\" | vt -- parse a string and show trees as graph script", - mkEx "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac" - ], - options = [ - ("api", "show the tree with function names converted to 'mkC' with value cats C"), - ("nofun","don't show functions but only categories"), - ("nocat","don't show categories but only functions") - ], - flags = [ - ("format","format of the visualization file (default \"png\")"), - ("view","program to open the resulting file (default \"open\")"), - ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"), - ("nodecolor","color for tree nodes (default: black -- graphviz standard color)"), - ("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)") - ] - }), - - ("ai", emptyCommandInfo { - longname = "abstract_info", - syntax = "ai IDENTIFIER or ai EXPR", - synopsis = "Provides an information about a function, an expression or a category from the abstract syntax", - explanation = unlines [ - "The command has one argument which is either function, expression or", - "a category defined in the abstract syntax of the current grammar. ", - "If the argument is a function then its type is printed out.", - "If it is a category then the category definition is printed.", - "If a whole expression is given it prints the expression with refined", - "metavariables and the type of the expression." - ], - exec = needPGF $ \opts args env@(pgf,cncs) -> - case map cExpr (toExprs args) of - [e] -> case unApp e of - Just (id,[]) -> return (fromString - (case functionType pgf id of - Just ty -> showFun id ty - Nothing -> let funs = functionsByCat pgf id - in showCat id funs)) - where - showCat c funs = "cat "++c++ - " ;\n\n"++ - unlines [showFun f ty| f<-funs, - Just ty <- [functionType pgf f]] - showFun f ty = "fun "++f++" : "++showType [] ty++" ;" - _ -> case inferExpr pgf e of - Left msg -> error msg - Right (e,ty) -> do putStrLn ("Expression: "++PGF2.showExpr [] e) - putStrLn ("Type: "++PGF2.showType [] ty) - putStrLn ("Probability: "++show (treeProbability pgf e)) - return void - _ -> do putStrLn "a single function name or category name is expected" - return void, - needsTypeCheck = False - }) - ] - where - cParse env@(pgf,_) opts ss = - parsed [ parse cnc cat s | s<-ss,(lang,cnc)<-cncs] - where - cat = optType pgf opts - cncs = optConcs env opts - parsed rs = Piped (Exprs ts,unlines msgs) - where - ts = [hsExpr t|ParseOk ts<-rs,(t,p)<-takeOptNum opts ts] - msgs = concatMap mkMsg rs - - mkMsg (ParseOk ts) = (map (PGF2.showExpr [] . fst).takeOptNum opts) ts - mkMsg (ParseFailed _ tok) = ["Parse failed: "++tok] - mkMsg (ParseIncomplete) = ["The sentence is incomplete"] - - optLins env opts ts = case opts of - _ | isOpt "groups" opts -> - concatMap snd $ groupResults - [[(lang, s) | (lang,concr) <- optConcs env opts,s <- linear opts lang concr t] | t <- ts] - _ -> concatMap (optLin env opts) ts - optLin env@(pgf,_) opts t = - case opts of - _ | isOpt "treebank" opts -> - (abstractName pgf ++ ": " ++ PGF2.showExpr [] t) : - [lang ++ ": " ++ s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t] - _ -> [s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t] - - linear :: [Option] -> ConcName -> Concr -> PGF2.Expr -> [String] - linear opts lang concr = case opts of - _ | isOpt "all" opts -> concat . map (map snd) . tabularLinearizeAll concr - _ | isOpt "list" opts -> (:[]) . commaList . - concatMap (map snd) . tabularLinearizeAll concr - _ | isOpt "table" opts -> concatMap (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr - _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr - _ -> (:[]) . linearize concr - - groupResults :: [[(ConcName,String)]] -> [(ConcName,[String])] - groupResults = Map.toList . foldr more Map.empty . start . concat - where - start ls = [(l,[s]) | (l,s) <- ls] - more (l,s) = - Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s - - optConcs = optConcsFlag "lang" - - optConcsFlag f (pgf,cncs) opts = - case valStrOpts f "" opts of - "" -> Map.toList cncs - lang -> mapMaybe pickLang (chunks ',' lang) - where - pickLang l = pick l `mplus` pick fl - where - fl = abstractName pgf++l - pick l = (,) l `fmap` Map.lookup l cncs - -{- - -- replace each non-atomic constructor with mkC, where C is the val cat - tree2mk pgf = H.showExpr [] . t2m where - t2m t = case H.unApp t of - Just (cid,ts@(_:_)) -> H.mkApp (mk cid) (map t2m ts) - _ -> t - mk = H.mkCId . ("mk" ++) . H.showCId . H.lookValCat (H.abstract pgf) - - unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- - - getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of - lexs -> case lookup lang - [(H.mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of - Just le -> chunks ',' le - _ -> [] --} - commaList [] = [] - commaList ws = concat $ head ws : map (", " ++) (tail ws) - - optFile opts = valStrOpts "file" "_gftmp" opts - - optType pgf opts = - case listFlags "cat" opts of - v:_ -> let str = valueString v - in case readType str of - Just ty -> case checkType pgf ty of - Left msg -> error msg - Right ty -> ty - Nothing -> error ("Can't parse '"++str++"' as a type") - _ -> startCat pgf - - optViewFormat opts = valStrOpts "format" "png" opts - optViewGraph opts = valStrOpts "view" "open" opts -{- - optNum opts = valIntOpts "number" 1 opts --} - optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 - takeOptNum opts = take (optNumInf opts) - - returnFromCExprs = returnFromExprs . map hsExpr - returnFromExprs es = - return $ case es of - [] -> pipeMessage "no trees found" - _ -> fromExprs es - - prGrammar env@(pgf,cncs) opts - | isOpt "langs" opts = return . fromString . unwords $ (map fst (optConcs env opts)) - | isOpt "cats" opts = return . fromString . unwords $ categories pgf - | isOpt "funs" opts = return . fromString . unwords $ functions pgf - | isOpt "missing" opts = return . fromString . unwords $ - [f | f <- functions pgf, not (and [hasLinearization concr f | (_,concr) <- optConcs env opts])] - | isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . snd) $ optConcs env opts - | isOpt "words" opts = return $ fromString $ concatMap (prAllWords . snd) $ optConcs env opts - | isOpt "lexc" opts = return $ fromString $ concatMap (prLexcLexicon . snd) $ optConcs env opts - | otherwise = return void - - gizaAlignment pgf src_cnc tgt_cnc e = - let src_res = alignWords src_cnc e - tgt_res = alignWords tgt_cnc e - alignment = [show i++"-"++show j | (i,(_,src_fids)) <- zip [0..] src_res, (j,(_,tgt_fids)) <- zip [0..] tgt_res, not (null (intersect src_fids tgt_fids))] - in (unwords (map fst src_res), unwords (map fst tgt_res), unwords alignment) - - morphos env opts s = - [(s,res) | (lang,concr) <- optConcs env opts, let res = lookupMorpho concr s, not (null res)] -{- - mexp xs = case xs of - t:_ -> Just t - _ -> Nothing --} - -- ps -f -g s returns g (f s) -{- - treeOps pgf opts s = foldr app s (reverse opts) where - app (OOpt op) | Just (Left f) <- treeOp pgf op = f - app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (H.mkCId x) - app _ = id - -treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] -treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] - -translationQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Language -> H.Type -> IO () -translationQuiz mex pgf ig og typ = do - tts <- translationList mex pgf ig og typ infinity - mkQuiz "Welcome to GF Translation Quiz." tts - -morphologyQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Type -> IO () -morphologyQuiz mex pgf ig typ = do - tts <- morphologyList mex pgf ig typ infinity - mkQuiz "Welcome to GF Morphology Quiz." tts - --- | the maximal number of precompiled quiz problems -infinity :: Int -infinity = 256 --} -prLexcLexicon :: Concr -> String -prLexcLexicon concr = - unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"] - where - morpho = fullFormLexicon concr - prLexc l p = l ++ concat (mkTags (words p)) - mkTags p = case p of - "s":ws -> mkTags ws --- remove record field - ws -> map ('+':) ws - - multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps] - -- thick_A+(AAdj+Posit+Gen):thick's # ; - -prFullFormLexicon :: Concr -> String -prFullFormLexicon concr = - unlines (map prMorphoAnalysis (fullFormLexicon concr)) - -prAllWords :: Concr -> String -prAllWords concr = - unwords [w | (w,_) <- fullFormLexicon concr] - -prMorphoAnalysis :: (String,[MorphoAnalysis]) -> String -prMorphoAnalysis (w,lps) = - unlines (w:[fun ++ " : " ++ cat | (fun,cat,p) <- lps]) - -hsExpr c = - case unApp c of - Just (f,cs) -> H.mkApp (H.mkCId f) (map hsExpr cs) - _ -> case unStr c of - Just str -> H.mkStr str - _ -> error $ "GF.Command.Commands2.hsExpr "++show c - -cExpr e = - case H.unApp e of - Just (f,es) -> mkApp (H.showCId f) (map cExpr es) - _ -> case H.unStr e of - Just str -> mkStr str - _ -> error $ "GF.Command.Commands2.cExpr "++show e - -needPGF exec opts ts = - do Env mb_pgf cncs <- getPGFEnv - case mb_pgf of - Just pgf -> liftSIO $ exec opts ts (pgf,cncs) - _ -> fail "Import a grammar before using this command" diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs index 69ccaf325..e85961e8a 100644 --- a/src/compiler/GF/Command/CommonCommands.hs +++ b/src/compiler/GF/Command/CommonCommands.hs @@ -15,7 +15,7 @@ import GF.Text.Pretty import GF.Text.Transliterations import GF.Text.Lexing(stringOp,opInEnv) -import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..)) +import PGF2(showExpr) extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased @@ -101,9 +101,7 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [ "To see transliteration tables, use command ut." ], examples = [ --- mkEx "l (EAdd 3 4) | ps -code -- linearize code-like output", mkEx "l (EAdd 3 4) | ps -unlexcode -- linearize code-like output", --- mkEx "ps -lexer=code | p -cat=Exp -- parse code-like input", mkEx "ps -lexcode | p -cat=Exp -- parse code-like input", mkEx "gr -cat=QCl | l | ps -bind -- linearization output from LangFin", mkEx "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal", @@ -175,12 +173,6 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [ mkEx "gt | l | ? wc -- generate trees, linearize, and count words" ] }), - ("tt", emptyCommandInfo { - longname = "to_trie", - syntax = "to_trie", - synopsis = "combine a list of trees into a trie", - exec = \ _ -> return . fromString . trie . toExprs - }), ("ut", emptyCommandInfo { longname = "unicode_table", synopsis = "show a transliteration table for a unicode character set", @@ -228,7 +220,6 @@ envFlag fs = _ -> Nothing stringOpOptions = sort $ [ - ("bind","bind tokens separated by Prelude.BIND, i.e. &+"), ("chars","lexer that makes every non-space character a token"), ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"), ("from_utf8","decode from utf8 (default)"), @@ -253,19 +244,6 @@ stringOpOptions = sort $ [ ("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] | (p,n) <- transliterationPrintNames] -trie = render . pptss . H.toTrie . map H.toATree - where - pptss [ts] = "*"<+>nest 2 (ppts ts) - pptss tss = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss] - - ppts = vcat . map ppt - - ppt t = - case t of - H.Oth e -> pp (H.showExpr [] e) - H.Ap f [[]] -> pp (H.showCId f) - H.Ap f tss -> H.showCId f $$ nest 2 (pptss tss) - -- ** Converting command input toString = unwords . toStrings toLines = unlines . toStrings diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index db4476687..b7a591f89 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/src/compiler/GF/Command/Importing.hs @@ -1,7 +1,7 @@ module GF.Command.Importing (importGrammar, importSource) where -import PGF -import PGF.Internal(unionPGF) +import PGF2 +import PGF2.Internal(unionPGF) import GF.Compile import GF.Compile.Multi (readMulti) diff --git a/src/compiler/GF/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs index e1f8cd6f8..d22523bd1 100644 --- a/src/compiler/GF/Command/Interpreter.hs +++ b/src/compiler/GF/Command/Interpreter.hs @@ -6,8 +6,8 @@ module GF.Command.Interpreter ( import GF.Command.CommandInfo import GF.Command.Abstract import GF.Command.Parse -import PGF import GF.Infra.UseIO(putStrLnE) +import PGF2 import Control.Monad(when) import qualified Data.Map as Map diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs index 9ead12e7e..e7b36e239 100644 --- a/src/compiler/GF/Command/Parse.hs +++ b/src/compiler/GF/Command/Parse.hs @@ -1,6 +1,6 @@ module GF.Command.Parse(readCommandLine, pCommand) where -import PGF(pExpr,pIdent) +import PGF2(pExpr,pIdent) import GF.Grammar.Parser(runPartial,pTerm) import GF.Command.Abstract @@ -22,7 +22,7 @@ pCommandLine = pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|') pCommand = (do - cmd <- pIdent <++ (char '%' >> fmap ('%':) pIdent) + cmd <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent)) skipSpaces opts <- sepBy pOption skipSpaces arg <- if getCommandOp cmd == "cc" then pArgTerm else pArgument @@ -37,7 +37,7 @@ pCommand = (do pOption = do char '-' - flg <- pIdent + flg <- readS_to_P pIdent option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue)) pValue = do @@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where pArgument = option ANoArg - (fmap AExpr pExpr + (fmap AExpr (readS_to_P pExpr) <++ - (skipSpaces >> char '%' >> fmap AMacro pIdent)) + (skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent))) pArgTerm = ATerm `fmap` readS_to_P sTerm where diff --git a/src/compiler/GF/Command/TreeOperations.hs b/src/compiler/GF/Command/TreeOperations.hs index fc0e6616d..9b17fba45 100644 --- a/src/compiler/GF/Command/TreeOperations.hs +++ b/src/compiler/GF/Command/TreeOperations.hs @@ -4,15 +4,15 @@ module GF.Command.TreeOperations ( treeChunks ) where -import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions) +import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions) import Data.List type TreeOp = [Expr] -> [Expr] -treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp)) +treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp)) treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf -allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))] +allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))] allTreeOps pgf = [ ("compute",("compute by using semantic definitions (def)", Left $ map (compute pgf))), diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index fcfe09168..587558e74 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -22,7 +22,7 @@ import Data.List(nub) import Data.Time(UTCTime) import GF.Text.Pretty(render,($$),(<+>),nest) -import PGF(PGF,readProbabilitiesFromFile) +import PGF2(PGF,readProbabilitiesFromFile) -- | Compiles a number of source files and builds a 'PGF' structure for them. -- This is a composition of 'link' and 'batchCompile'. diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index eb97b72a4..3bc3e8f90 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -6,8 +6,8 @@ import GF.Infra.UseIO import GF.Infra.Option import GF.Compile.OptimizePGF -import PGF -import PGF.Internal +import PGF2 +import PGF2.Internal import qualified Data.Set as Set import qualified Data.Map as Map @@ -20,22 +20,22 @@ import Data.Maybe(fromMaybe) -- the compiler ---------- -------------------------- -cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map CId Double -> PGF +cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF cf2pgf opts fpath cf probs = build (let abstr = cf2abstr cf probs in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)]) where name = justModuleName fpath - aname = mkCId (name ++ "Abs") - cname = mkCId name + aname = name ++ "Abs" + cname = name -cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map CId Double -> B s AbstrInfo +cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo cf2abstr cfg probs = newAbstr aflags acats afuns where - aflags = [(mkCId "startcat", LStr (fst (cfgStartCat cfg)))] + aflags = [("startcat", LStr (fst (cfgStartCat cfg)))] acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat] - afuns = [(f', dTyp [hypo Explicit wildCId (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) + afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | rule <- allRules cfg , let f' = mkRuleName rule] @@ -53,12 +53,12 @@ cf2abstr cfg probs = newAbstr aflags acats afuns toLogProb = realToFrac . negate . log - cat2id = mkCId . fst + cat2id = fst cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo cf2concr opts abstr cfg = let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') = - (if flag optOptimizePGF opts then optimizePGF (mkCId (fst (cfgStartCat cfg))) else id) + (if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id) (lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats) in newConcr abstr [] [] lindefs' linrefs' @@ -74,7 +74,7 @@ cf2concr opts abstr cfg = map mkSequence rules) sequences = Set.toList sequences0 - idFun = (wildCId,[Set.findIndex idSeq sequences0]) + idFun = ("_",[Set.findIndex idSeq sequences0]) ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules productions = foldl addProd IntMap.empty (concat (productions0++coercions)) cncfuns = reverse cncfuns0 @@ -100,11 +100,11 @@ cf2concr opts abstr cfg = convertSymbol d (Terminal t) = (d, SymKS t) mkCncCat fid (cat,n) - | cat == "Int" = (fid, (mkCId cat, fidInt, fidInt, lbls)) - | cat == "Float" = (fid, (mkCId cat, fidFloat, fidFloat, lbls)) - | cat == "String" = (fid, (mkCId cat, fidString, fidString, lbls)) + | cat == "Int" = (fid, (cat, fidInt, fidInt, lbls)) + | cat == "Float" = (fid, (cat, fidFloat, fidFloat, lbls)) + | cat == "String" = (fid, (cat, fidString, fidString, lbls)) | otherwise = let fid' = fid+n+1 - in fid' `seq` (fid', (mkCId cat, fid, fid+n, lbls)) + in fid' `seq` (fid', (cat, fid, fid+n, lbls)) mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[]) mkCoercions (fid,cs) c@(cat,ps ) = @@ -120,7 +120,7 @@ cf2concr opts abstr cfg = Nothing -> IntMap.insert fid [prod] prods cat2fid cat p = - case [start | (cat',start,_,_) <- cnccats, mkCId cat == cat'] of + case [start | (cat',start,_,_) <- cnccats, cat == cat'] of (start:_) -> fid+p _ -> error "cat2fid" @@ -133,5 +133,5 @@ cf2concr opts abstr cfg = mkRuleName rule = case ruleName rule of CFObj n _ -> n - _ -> wildCId + _ -> "_" diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index 7eb0c3bfb..90f0ee092 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -1,6 +1,6 @@ module GF.Compile.Compute.Value where import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent) -import PGF.Internal(BindType) +import PGF2(BindType) import GF.Infra.Ident(Ident) import Text.Show.Functions() import Data.Ix(Ix) diff --git a/src/compiler/GF/Compile/ExampleBased.hs b/src/compiler/GF/Compile/ExampleBased.hs index 9300fd32d..e07f79a5f 100644 --- a/src/compiler/GF/Compile/ExampleBased.hs +++ b/src/compiler/GF/Compile/ExampleBased.hs @@ -3,11 +3,7 @@ module GF.Compile.ExampleBased ( configureExBased ) where -import PGF ---import PGF.Probabilistic ---import PGF.Morphology ---import GF.Compile.ToAPI - +import PGF2 import Data.List parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String]) @@ -37,47 +33,38 @@ convertFile conf src file = do (ex, end) = break (=='"') (tail exend) in ((unwords (words cat),ex), tail end) -- quotes ignored pgf = resource_pgf conf - morpho = resource_morpho conf lang = language conf convEx (cat,ex) = do appn "(" let typ = maybe (error "no valid cat") id $ readType cat - ws <- case fst (parse_ pgf lang typ (Just 4) ex) of - ParseFailed _ -> do - let ws = morphoMissing morpho (words ex) + ws <- case parse lang typ ex of + ParseFailed _ _ -> do appv ("WARNING: cannot parse example " ++ ex) - case ws of - [] -> return () - _ -> appv (" missing words: " ++ unwords ws) - return ws - TypeError _ -> return [] ParseIncomplete -> return [] ParseOk ts -> - case rank ts of + case ts of (t:tt) -> do if null tt then return () else appv ("WARNING: ambiguous example " ++ ex) - appn t - mapM_ (appn . (" --- " ++)) tt + appn (printExp conf (fst t)) + mapM_ (appn . (" --- " ++) . printExp conf . fst) tt appn ")" return [] return ws - rank ts = [printExp conf t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts] appf = appendFile file appn s = appf s >> appf "\n" appv s = appn ("--- " ++ s) >> putStrLn s data ExConfiguration = ExConf { - resource_pgf :: PGF, - resource_morpho :: Morpho, + resource_pgf :: PGF, verbose :: Bool, - language :: Language, - printExp :: Tree -> String + language :: Concr, + printExp :: Expr -> String } -configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration -configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr +configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration +configureExBased pgf concr pr = ExConf pgf False concr pr diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index d89792677..befd7a4f8 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -4,7 +4,7 @@ module GF.Compile.GenerateBC(generateByteCode) where import GF.Grammar import GF.Grammar.Lookup(lookupAbsDef,lookupFunType) import GF.Data.Operations -import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..)) +import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..)) import qualified Data.Map as Map import Data.List(nub,mapAccumL) import Data.Maybe(fromMaybe) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 0e20ea5e4..d4d05d792 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -13,8 +13,9 @@ module GF.Compile.GeneratePMCFG (generatePMCFG, pgfCncCat, addPMCFG, resourceValues ) where ---import PGF.CId -import PGF.Internal as PGF(CId,Symbol(..),fidVar) +import qualified PGF2 as PGF2 +import qualified PGF2.Internal as PGF2 +import PGF2.Internal(Symbol(..),fidVar) import GF.Infra.Option import GF.Grammar hiding (Env, mkRecord, mkTable) @@ -68,7 +69,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m --addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info) -addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do +addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do --when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...") let pres = protoFCat gr res val pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont] @@ -92,7 +93,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs))) seqs1 `seq` stats `seq` return () when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats) - return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg)) + return (seqs1,CncFun mty mlin mprn (Just pmcfg)) where (ctxt,res,_) = err bug typeForm (lookupFunType gr am id) @@ -102,11 +103,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont newArgs = map getFIds newArgs' in addFunction env0 newCat fun newArgs -addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) - mdef@(Just (L loc1 def)) - mref@(Just (L loc2 ref)) - mprn - Nothing) = do +addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat)) + mdef@(Just (L loc1 def)) + mref@(Just (L loc2 ref)) + mprn + Nothing) = do let pcat = protoFCat gr (am,id) lincat pvar = protoFCat gr (MN identW,cVar) typeStr @@ -131,7 +132,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc let pmcfg = getPMCFG pmcfgEnv2 when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat)) - seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg)) + seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg)) where addLindef lins (newCat', newArgs') env0 = let [newCat] = getFIds newCat' @@ -157,7 +158,7 @@ convert opts gr cenv loc term ty@(_,val) pargs = args = map Vr vars vars = map (\(bt,x,t) -> x) context -pgfCncCat :: SourceGrammar -> CId -> Type -> Int -> (CId,Int,Int,[String]) +pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String]) pgfCncCat gr id lincat index = let ((_,size),schema) = computeCatRange gr lincat in ( id @@ -474,7 +475,7 @@ goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss ---------------------------------------------------------------------- -- SeqSet -type SeqSet = Map.Map Sequence SeqId +type SeqSet = Map.Map [Symbol] SeqId addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId)) addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 33f35ad08..fef72fc28 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -18,7 +18,7 @@ import GF.Compile.Compute.Predef(predef) import GF.Compile.Compute.Value(Predefined(..)) import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) import GF.Infra.Option(optionsPGF) -import PGF.Internal(Literal(..)) +import PGF2.Internal(Literal(..)) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import GF.Grammar.Canonical as C import Debug.Trace diff --git a/src/compiler/GF/Compile/OptimizePGF.hs b/src/compiler/GF/Compile/OptimizePGF.hs index 1f8b0d658..f440c58d2 100644 --- a/src/compiler/GF/Compile/OptimizePGF.hs +++ b/src/compiler/GF/Compile/OptimizePGF.hs @@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-} module GF.Compile.OptimizePGF(optimizePGF) where -import PGF(mkCId) -import PGF.Internal +import PGF2(Cat,Fun) +import PGF2.Internal import Data.Array.ST import Data.Array.Unboxed import qualified Data.Map as Map @@ -15,19 +15,19 @@ import Control.Monad.ST type ConcrData = ([(FId,[FunId])], -- ^ Lindefs [(FId,[FunId])], -- ^ Linrefs [(FId,[Production])], -- ^ Productions - [(CId,[SeqId])], -- ^ Concrete functions (must be sorted by Fun) + [(Fun,[SeqId])], -- ^ Concrete functions (must be sorted by Fun) [[Symbol]], -- ^ Sequences (must be sorted) - [(CId,FId,FId,[String])]) -- ^ Concrete categories + [(Cat,FId,FId,[String])]) -- ^ Concrete categories -optimizePGF :: CId -> ConcrData -> ConcrData +optimizePGF :: Cat -> ConcrData -> ConcrData optimizePGF startCat = topDownFilter startCat . bottomUpFilter -cidString = mkCId "String" -cidInt = mkCId "Int" -cidFloat = mkCId "Float" -cidVar = mkCId "__gfVar" - -topDownFilter :: CId -> ConcrData -> ConcrData +catString = "String" +catInt = "Int" +catFloat = "Float" +catVar = "__gfVar" + +topDownFilter :: Cat -> ConcrData -> ConcrData topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) = let env0 = (Map.empty,Map.empty) (env1,lindefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids'))) @@ -43,10 +43,10 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) = (sequences',cncfuns') = env3 in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray sequences',cnccats') where - cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (CId, [SeqId]) + cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (Fun, [SeqId]) sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol] prods_map = IntMap.fromList prods - fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats, + fid2catMap = IntMap.fromList ((fidVar,catVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats, fid <- [start..end]]) fid2cat fid = @@ -76,17 +76,17 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) = -- An element of the array is equal to -1 if the corresponding index -- is not going to be used in the optimized grammar, or the new index -- if it will be used - closure :: Map.Map CId [LIndex] + closure :: Map.Map Cat [Int] closure = runST $ do set <- initSet - addLitCat cidString set - addLitCat cidInt set - addLitCat cidFloat set - addLitCat cidVar set + addLitCat catString set + addLitCat catInt set + addLitCat catFloat set + addLitCat catVar set closureSet set starts doneSet set where - initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex)) + initSet :: ST s (Map.Map Cat (STUArray s Int Int)) initSet = fmap Map.fromList $ sequence [fmap ((,) cat) (newArray (0,length lbls-1) (-1)) @@ -109,7 +109,7 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) = else closureSet set xs Nothing -> error "unknown cat" - doneSet :: Map.Map CId (STUArray s LIndex LIndex) -> ST s (Map.Map CId [LIndex]) + doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int]) doneSet set = fmap Map.fromAscList $ mapM done (Map.toAscList set) where diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index 7520d6894..c6d00b794 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -16,8 +16,8 @@ module GF.Compile.PGFtoHaskell (grammar2haskell) where -import PGF -import PGF.Internal +import PGF2 +import PGF2.Internal import GF.Data.Operations import GF.Infra.Option @@ -242,7 +242,7 @@ fInstance gId lexical m (cat,rules) = then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of" else " case unApp t of") ++++ unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ - (if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++ + (if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++ " _ -> error (\"no" +++ cat ++ " \" ++ show t)" where isList = isListCat (cat,rules) @@ -263,11 +263,11 @@ fInstance gId lexical m (cat,rules) = --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] hSkeleton :: PGF -> (String,HSkeleton) hSkeleton gr = - (showCId (abstractName gr), + (abstractName gr, let fs = - [(showCId c, [(showCId f, map showCId cs) | (f, cs,_) <- fs]) | + [(c, [(f, cs) | (f, cs,_) <- fs]) | fs@((_, _,c):_) <- fns] - in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)] + in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)] ) where cts = categories gr diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs index e634dae67..dbb65908b 100644 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -1,156 +1,110 @@ module GF.Compile.PGFtoJSON (pgf2json) where -import PGF (showCId) -import qualified PGF.Internal as M -import PGF.Internal ( - Abstr, - CId, - CncCat(..), - CncFun(..), - Concr, - DotPos, - Equation(..), - Literal(..), - PArg(..), - PGF, - Production(..), - Symbol(..), - Type, - absname, - abstract, - cflags, - cnccats, - cncfuns, - concretes, - funs, - productions, - sequences, - totalCats - ) - -import qualified Text.JSON as JSON -import Text.JSON (JSValue(..)) - -import qualified Data.Array.IArray as Array -import Data.Map (Map) -import qualified Data.Set as Set +import PGF2 +import PGF2.Internal +import Text.JSON import qualified Data.Map as Map -import qualified Data.IntMap as IntMap pgf2json :: PGF -> String pgf2json pgf = - JSON.encode $ JSON.makeObj - [ ("abstract", json_abstract) - , ("concretes", json_concretes) - ] - where - n = showCId $ absname pgf - as = abstract pgf - cs = Map.assocs (concretes pgf) - start = showCId $ M.lookStartCat pgf - json_abstract = abstract2json n start as - json_concretes = JSON.makeObj $ map concrete2json cs - -abstract2json :: String -> String -> Abstr -> JSValue -abstract2json name start ds = - JSON.makeObj - [ ("name", mkJSStr name) - , ("startcat", mkJSStr start) - , ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds))) + encode $ makeObj + [ ("abstract", abstract2json pgf) + , ("concretes", makeObj $ map concrete2json + (Map.toList (languages pgf))) ] -absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue) -absdef2json (f,(typ,_,_,_)) = (showCId f,sig) +abstract2json :: PGF -> JSValue +abstract2json pgf = + makeObj + [ ("name", showJSON (abstractName pgf)) + , ("startcat", showJSON (showType [] (startCat pgf))) + , ("funs", makeObj $ map (absdef2json pgf) (functions pgf)) + ] + +absdef2json :: PGF -> Fun -> (String,JSValue) +absdef2json pgf f = (f,sig) where - (args,cat) = M.catSkeleton typ - sig = JSON.makeObj - [ ("args", JSArray $ map (mkJSStr.showCId) args) - , ("cat", mkJSStr $ showCId cat) + Just (hypos,cat,_) = fmap unType (functionType pgf f) + sig = makeObj + [ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos) + , ("cat", showJSON cat) ] lit2json :: Literal -> JSValue -lit2json (LStr s) = mkJSStr s -lit2json (LInt n) = mkJSInt n -lit2json (LFlt d) = JSRational True (toRational d) +lit2json (LStr s) = showJSON s +lit2json (LInt n) = showJSON n +lit2json (LFlt d) = showJSON d -concrete2json :: (CId,Concr) -> (String,JSValue) -concrete2json (c,cnc) = (showCId c,obj) +concrete2json :: (ConcName,Concr) -> (String,JSValue) +concrete2json (c,cnc) = (c,obj) where - obj = JSON.makeObj - [ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ]) - , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)]) - , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc)))) - , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc)))) - , ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc))) - , ("totalfids", mkJSInt (totalCats cnc)) + obj = makeObj + [ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc]) + , ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]]) + , ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]]) + , ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]]) + , ("categories", makeObj $ map cat2json (concrCategories cnc)) + , ("totalfids", showJSON (concrTotalCats cnc)) ] -cats2json :: (CId, CncCat) -> (String,JSValue) -cats2json (c,CncCat start end _) = (showCId c, ixs) +cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue) +cat2json (cat,start,end,_) = (cat, ixs) where - ixs = JSON.makeObj - [ ("start", mkJSInt start) - , ("end", mkJSInt end) + ixs = makeObj + [ ("start", showJSON start) + , ("end", showJSON end) ] frule2json :: Production -> JSValue frule2json (PApply fid args) = - JSON.makeObj - [ ("type", mkJSStr "Apply") - , ("fid", mkJSInt fid) - , ("args", JSArray (map farg2json args)) + makeObj + [ ("type", showJSON "Apply") + , ("fid", showJSON fid) + , ("args", showJSON (map farg2json args)) ] frule2json (PCoerce arg) = - JSON.makeObj - [ ("type", mkJSStr "Coerce") - , ("arg", mkJSInt arg) + makeObj + [ ("type", showJSON "Coerce") + , ("arg", showJSON arg) ] farg2json :: PArg -> JSValue farg2json (PArg hypos fid) = - JSON.makeObj - [ ("type", mkJSStr "PArg") - , ("hypos", JSArray $ map (mkJSInt . snd) hypos) - , ("fid", mkJSInt fid) + makeObj + [ ("type", showJSON "PArg") + , ("hypos", JSArray $ map (showJSON . snd) hypos) + , ("fid", showJSON fid) ] -ffun2json :: CncFun -> JSValue -ffun2json (CncFun f lins) = - JSON.makeObj - [ ("name", mkJSStr $ showCId f) - , ("lins", JSArray (map mkJSInt (Array.elems lins))) +ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue +ffun2json funid (fun,seqids) = + makeObj + [ ("name", showJSON fun) + , ("lins", showJSON seqids) ] -seq2json :: Array.Array DotPos Symbol -> JSValue -seq2json seq = JSArray [sym2json s | s <- Array.elems seq] +seq2json :: SeqId -> [Symbol] -> JSValue +seq2json seqid seq = showJSON [sym2json sym | sym <- seq] sym2json :: Symbol -> JSValue -sym2json (SymCat n l) = new "SymCat" [mkJSInt n, mkJSInt l] -sym2json (SymLit n l) = new "SymLit" [mkJSInt n, mkJSInt l] -sym2json (SymVar n l) = new "SymVar" [mkJSInt n, mkJSInt l] -sym2json (SymKS t) = new "SymKS" [mkJSStr t] +sym2json (SymCat n l) = new "SymCat" [showJSON n, showJSON l] +sym2json (SymLit n l) = new "SymLit" [showJSON n, showJSON l] +sym2json (SymVar n l) = new "SymVar" [showJSON n, showJSON l] +sym2json (SymKS t) = new "SymKS" [showJSON t] sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)] -sym2json SymBIND = new "SymKS" [mkJSStr "&+"] -sym2json SymSOFT_BIND = new "SymKS" [mkJSStr "&+"] -sym2json SymSOFT_SPACE = new "SymKS" [mkJSStr "&+"] -sym2json SymCAPIT = new "SymKS" [mkJSStr "&|"] -sym2json SymALL_CAPIT = new "SymKS" [mkJSStr "&|"] +sym2json SymBIND = new "SymKS" [showJSON "&+"] +sym2json SymSOFT_BIND = new "SymKS" [showJSON "&+"] +sym2json SymSOFT_SPACE = new "SymKS" [showJSON "&+"] +sym2json SymCAPIT = new "SymKS" [showJSON "&|"] +sym2json SymALL_CAPIT = new "SymKS" [showJSON "&|"] sym2json SymNE = new "SymNE" [] alt2json :: ([Symbol],[String]) -> JSValue -alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)] +alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts] new :: String -> [JSValue] -> JSValue new f xs = - JSON.makeObj - [ ("type", mkJSStr f) - , ("args", JSArray xs) + makeObj + [ ("type", showJSON f) + , ("args", showJSON xs) ] - --- | Make JSON value from string -mkJSStr :: String -> JSValue -mkJSStr = JSString . JSON.toJSString - --- | Make JSON value from integer -mkJSInt :: Integral a => a -> JSValue -mkJSInt = JSRational False . toRational diff --git a/src/compiler/GF/Compile/PGFtoJava.hs b/src/compiler/GF/Compile/PGFtoJava.hs index 9aa7412a0..f50eb2961 100644 --- a/src/compiler/GF/Compile/PGFtoJava.hs +++ b/src/compiler/GF/Compile/PGFtoJava.hs @@ -1,6 +1,6 @@ module GF.Compile.PGFtoJava (grammar2java) where -import PGF +import PGF2 import Data.Maybe(maybe) import Data.List(intercalate) import GF.Infra.Option @@ -24,9 +24,8 @@ javaPreamble name = ] javaMethod gr fun = - " public static Expr "++name++"("++arg_decls++") { return new Expr("++show name++args++"); }" + " public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }" where - name = showCId fun arity = maybe 0 getArrity (functionType gr fun) vars = ['e':show i | i <- [1..arity]] diff --git a/src/compiler/GF/Compile/ToAPI.hs b/src/compiler/GF/Compile/ToAPI.hs index 83ae6539f..3b05f7ff7 100644 --- a/src/compiler/GF/Compile/ToAPI.hs +++ b/src/compiler/GF/Compile/ToAPI.hs @@ -2,7 +2,7 @@ module GF.Compile.ToAPI (stringToAPI,exprToAPI) where -import PGF +import PGF2 import Data.Maybe --import System.IO --import Control.Monad @@ -46,12 +46,12 @@ exprToFunc :: Expr -> APIfunc exprToFunc expr = case unApp expr of Just (cid,l) -> - case Map.lookup (showCId cid) syntaxFuncs of + case Map.lookup cid syntaxFuncs of Just sig -> mkAPI True (fst sig,expr) _ -> case l of - [] -> BasicFunc (showCId cid) + [] -> BasicFunc cid _ -> let es = map exprToFunc l - in AppFunc (showCId cid) es + in AppFunc cid es _ -> BasicFunc (showExpr [] expr) @@ -68,8 +68,8 @@ mkAPI opt (ty,expr) = where rephraseSentence ty expr = case unApp expr of - Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then - let newCat = drop 3 (showCId cid) + Just (cid,es) -> if isPrefixOf "Use" cid then + let newCat = drop 3 cid afClause = mkAPI True (newCat, es !! 2) afPol = mkAPI True ("Pol",es !! 1) lTense = mkAPI True ("Temp", head es) @@ -97,9 +97,9 @@ mkAPI opt (ty,expr) = computeAPI :: (String,Expr) -> APIfunc computeAPI (ty,expr) = case (unApp expr) of - Just (cid,[]) -> getSimpCat (showCId cid) ty + Just (cid,[]) -> getSimpCat cid ty Just (cid,es) -> - let p = specFunction (showCId cid) es + let p = specFunction cid es in if isJust p then fromJust p else case Map.lookup (show cid) syntaxFuncs of Nothing -> exprToFunc expr @@ -146,23 +146,23 @@ optimize expr = optimizeNP expr optimizeNP expr = case unApp expr of Just (cid,es) -> - if showCId cid == "MassNP" then let afs = nounAsCN (head es) - in AppFunc "mkNP" [afs] - else if showCId cid == "DetCN" then let quants = quantAsDet (head es) - ns = nounAsCN (head $ tail es) - in AppFunc "mkNP" (quants ++ [ns]) + if cid == "MassNP" then let afs = nounAsCN (head es) + in AppFunc "mkNP" [afs] + else if cid == "DetCN" then let quants = quantAsDet (head es) + ns = nounAsCN (head $ tail es) + in AppFunc "mkNP" (quants ++ [ns]) else mkAPI False ("NP",expr) _ -> error $ "incorrect expression " ++ (showExpr [] expr) where nounAsCN expr = case unApp expr of - Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es) + Just (cid,es) -> if cid == "UseN" then (mkAPI False) ("N",head es) else (mkAPI False) ("CN",expr) _ -> error $ "incorrect expression "++ (showExpr [] expr) quantAsDet expr = case unApp expr of - Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)] + Just (cid,es) -> if cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)] else [mkAPI False ("Det",expr)] _ -> error $ "incorrect expression "++ (showExpr [] expr) diff --git a/src/compiler/GF/Grammar/BNFC.hs b/src/compiler/GF/Grammar/BNFC.hs index 9d0915072..b9d2b3169 100644 --- a/src/compiler/GF/Grammar/BNFC.hs +++ b/src/compiler/GF/Grammar/BNFC.hs @@ -15,7 +15,6 @@ module GF.Grammar.BNFC(BNFCRule(..), BNFCSymbol, Symbol(..), CFTerm(..), bnfc2cf) where import GF.Grammar.CFG -import PGF (Token, mkCId) import Data.List (partition) type IsList = Bool @@ -64,12 +63,12 @@ transformRules sepMap (BNFCCoercions c num) = rules ++ [lastRule] lastRule = Rule (c',[0]) ss rn where c' = c ++ show num ss = [Terminal "(", NonTerminal (c,[0]), Terminal ")"] - rn = CFObj (mkCId $ "coercion_" ++ c) [] + rn = CFObj ("coercion_" ++ c) [] fRules c n = Rule (c',[0]) ss rn where c' = if n == 0 then c else c ++ show n ss = [NonTerminal (c ++ show (n+1),[0])] - rn = CFObj (mkCId $ "coercion_" ++ c') [] + rn = CFObj ("coercion_" ++ c') [] transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol) transformSymb sepMap s = case s of @@ -94,7 +93,7 @@ createListRules' ne isSep symb c = ruleBase : ruleCons then [NonTerminal (c,[0]) | ne] else [NonTerminal (c,[0]) | ne] ++ [Terminal symb | symb /= "" && ne] - rn = CFObj (mkCId $ "Base" ++ c) [] + rn = CFObj ("Base" ++ c) [] ruleCons | isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn ,Rule ("List" ++ c,[1]) smbs1 rn] @@ -107,4 +106,4 @@ createListRules' ne isSep symb c = ruleBase : ruleCons smbs = [NonTerminal (c,[0])] ++ [Terminal symb | symb /= ""] ++ [NonTerminal ("List" ++ c,[0])] - rn = CFObj (mkCId $ "Cons" ++ c) [] + rn = CFObj ("Cons" ++ c) [] diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 3ecdb0223..12eef3fbb 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -22,8 +22,7 @@ import GF.Infra.Option import GF.Infra.UseIO(MonadIO(..)) import GF.Grammar.Grammar -import PGF() -- Binary instances -import PGF.Internal(Literal(..),Symbol(..)) +import PGF2.Internal(Literal(..),Symbol(..)) -- Please change this every time when the GFO format is changed gfoVersion = "GF04" diff --git a/src/compiler/GF/Grammar/CFG.hs b/src/compiler/GF/Grammar/CFG.hs index aac13bcba..9d73c3b48 100644 --- a/src/compiler/GF/Grammar/CFG.hs +++ b/src/compiler/GF/Grammar/CFG.hs @@ -4,10 +4,11 @@ -- -- Context-free grammar representation and manipulation. ---------------------------------------------------------------------- -module GF.Grammar.CFG where +module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where import GF.Data.Utilities -import PGF +import PGF2(Fun,Cat) +import PGF2.Internal(Token) import GF.Data.Relation import Data.Map (Map) @@ -20,8 +21,6 @@ import qualified Data.Set as Set -- * Types -- -type Cat = String - data Symbol c t = NonTerminal c | Terminal t deriving (Eq, Ord, Show) @@ -39,12 +38,12 @@ data Grammar c t = Grammar { deriving (Eq, Ord, Show) data CFTerm - = CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments + = CFObj Fun [CFTerm] -- ^ an abstract syntax function with arguments | CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id. | CFApp CFTerm CFTerm -- ^ Application | CFRes Int -- ^ The result of the n:th (0-based) non-terminal | CFVar Int -- ^ A lambda-bound variable - | CFMeta CId -- ^ A metavariable + | CFMeta Fun -- ^ A metavariable deriving (Eq, Ord, Show) type CFSymbol = Symbol Cat Token @@ -232,7 +231,7 @@ uniqueFuns = snd . mapAccumL uniqueFun Set.empty uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args)) where fun' = head [fun'|suffix<-"":map show ([2..]::[Int]), - let fun'=mkCId (showCId fun++suffix), + let fun'=fun++suffix, not (fun' `Set.member` funs)] -- | Gets all rules in a CFG. @@ -310,12 +309,12 @@ prProductions prods = prCFTerm :: CFTerm -> String prCFTerm = pr 0 where - pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")") + pr p (CFObj f args) = paren p (f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")") pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t) pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")") pr _ (CFRes i) = "$" ++ show i pr _ (CFVar i) = "x" ++ show i - pr _ (CFMeta c) = "?" ++ showCId c + pr _ (CFMeta c) = "?" ++ c paren 0 x = x paren 1 x = "(" ++ x ++ ")" @@ -323,12 +322,12 @@ prCFTerm = pr 0 -- * CFRule Utilities -- -ruleFun :: Rule c t -> CId +ruleFun :: Rule c t -> Fun ruleFun (Rule _ _ t) = f t where f (CFObj n _) = n f (CFApp _ x) = f x f (CFAbs _ x) = f x - f _ = mkCId "" + f _ = "" -- | Check if any of the categories used on the right-hand side -- are in the given list of categories. @@ -336,7 +335,7 @@ anyUsedBy :: Eq c => [c] -> Rule c t -> Bool anyUsedBy cs (Rule _ ss _) = any (`elem` cs) (filterCats ss) mkCFTerm :: String -> CFTerm -mkCFTerm n = CFObj (mkCId n) [] +mkCFTerm n = CFObj n [] ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs diff --git a/src/compiler/GF/Grammar/EBNF.hs b/src/compiler/GF/Grammar/EBNF.hs index 9d617c26a..6302a7b93 100644 --- a/src/compiler/GF/Grammar/EBNF.hs +++ b/src/compiler/GF/Grammar/EBNF.hs @@ -16,7 +16,6 @@ module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where import GF.Data.Operations import GF.Grammar.CFG -import PGF (mkCId) type EBNF = [ERule] type ERule = (ECat, ERHS) @@ -40,7 +39,7 @@ ebnf2cf :: EBNF -> [ParamCFRule] ebnf2cf ebnf = [Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)] where - mkCFF i (c,_) = CFObj (mkCId ("Mk" ++ c ++ "_" ++ show i)) [] + mkCFF i (c,_) = CFObj ("Mk" ++ c ++ "_" ++ show i) [] normEBNF :: EBNF -> [CFJustRule] normEBNF erules = let diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 587b09a9f..d79f31775 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -64,7 +64,7 @@ module GF.Grammar.Grammar ( Location(..), L(..), unLoc, noLoc, ppLocation, ppL, -- ** PMCFG - PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence + PMCFG(..), Production(..), FId, FunId, SeqId, LIndex ) where import GF.Infra.Ident @@ -73,7 +73,8 @@ import GF.Infra.Location import GF.Data.Operations -import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..)) +import PGF2(LIndex, BindType(..)) +import PGF2.Internal(FId, FunId, SeqId, Symbol) import Data.Array.IArray(Array) import Data.Array.Unboxed(UArray) @@ -99,7 +100,7 @@ data ModuleInfo = ModInfo { mopens :: [OpenSpec], mexdeps :: [ModuleName], msrc :: FilePath, - mseqs :: Maybe (Array SeqId Sequence), + mseqs :: Maybe (Array SeqId [Symbol]), jments :: Map.Map Ident Info } diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 9377bd7d5..d347bf74c 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -24,7 +24,6 @@ import GF.Grammar.Lexer import GF.Compile.Update (buildAnyTree) import Data.List(intersperse) import Data.Char(isAlphaNum) -import PGF(mkCId) } @@ -624,7 +623,7 @@ ListCFRule CFRule :: { [BNFCRule] } CFRule - : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])] + : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])] } | Ident '::=' ListCFRHS ';' { let { cat = showIdent $1; mkFun cat its = @@ -637,7 +636,7 @@ CFRule Terminal c -> filter isAlphaNum c; NonTerminal (t,_) -> t } - } in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3 + } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3 } | 'coercions' Ident Integer ';' { [BNFCCoercions (showIdent $2) $3]} | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] } diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 58892db11..f7378494c 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -23,19 +23,16 @@ module GF.Grammar.Printer , getAbs ) where +import PGF2 as PGF2 +import PGF2.Internal as PGF2 import GF.Infra.Ident import GF.Infra.Option import GF.Grammar.Values import GF.Grammar.Grammar - -import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq) - import GF.Text.Pretty import Data.Maybe (isNothing) import Data.List (intersperse) import qualified Data.Map as Map ---import qualified Data.IntMap as IntMap ---import qualified Data.Set as Set import qualified Data.Array.IArray as Array data TermPrintQual @@ -362,3 +359,39 @@ getLet (Let l e) = let (ls,e') = getLet e in (l:ls,e') getLet e = ([],e) +ppFunId funid = pp 'F' <> pp funid +ppSeqId seqid = pp 'S' <> pp seqid + +ppFId fid + | fid == PGF2.fidString = pp "CString" + | fid == PGF2.fidInt = pp "CInt" + | fid == PGF2.fidFloat = pp "CFloat" + | fid == PGF2.fidVar = pp "CVar" + | fid == PGF2.fidStart = pp "CStart" + | otherwise = pp 'C' <> pp fid + +ppMeta :: Int -> Doc +ppMeta n + | n == 0 = pp '?' + | otherwise = pp '?' <> pp n + +ppLit (PGF2.LStr s) = pp (show s) +ppLit (PGF2.LInt n) = pp n +ppLit (PGF2.LFlt d) = pp d + +ppSeq (seqid,seq) = + ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq) + +ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>' +ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}' +ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>' +ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t) +ppSymbol PGF2.SymNE = pp "nonExist" +ppSymbol PGF2.SymBIND = pp "BIND" +ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND" +ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE" +ppSymbol PGF2.SymCAPIT = pp "CAPIT" +ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT" +ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts))) + +ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps) diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index f30ee79c9..0c9745a35 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -35,7 +35,7 @@ import GF.Infra.Ident import GF.Infra.GetOpt import GF.Grammar.Predef import System.FilePath -import PGF.Internal(Literal(..)) +import PGF2.Internal(Literal(..)) import GF.Data.Operations(Err,ErrorMonad(..),liftErr) @@ -85,12 +85,9 @@ data Phase = Preproc | Convert | Compile | Link data OutputFormat = FmtPGFPretty | FmtCanonicalGF | FmtCanonicalJson - | FmtJavaScript | FmtJSON - | FmtPython | FmtHaskell | FmtJava - | FmtProlog | FmtBNF | FmtEBNF | FmtRegular @@ -467,12 +464,9 @@ outputFormatsExpl = [(("pgf_pretty", FmtPGFPretty),"human-readable pgf"), (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"), - (("js", FmtJavaScript),"JavaScript (whole grammar)"), (("json", FmtJSON),"JSON (whole grammar)"), - (("python", FmtPython),"Python (whole grammar)"), (("haskell", FmtHaskell),"Haskell (abstract syntax)"), (("java", FmtJava),"Java (abstract syntax)"), - (("prolog", FmtProlog),"Prolog (whole grammar)"), (("bnf", FmtBNF),"BNF (context-free grammar)"), (("ebnf", FmtEBNF),"Extended BNF"), (("regular", FmtRegular),"* regular grammar"), diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 2a12257b7..db6d6111c 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -5,7 +5,7 @@ module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where import Prelude hiding (putStrLn,print) import qualified Prelude as P(putStrLn) import GF.Command.Interpreter(CommandEnv(..),mkCommandEnv,interpretCommandLine) -import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands) +import GF.Command.Commands(HasPGF(..),pgfCommands) import GF.Command.CommonCommands(commonCommands,extend) import GF.Command.SourceCommands import GF.Command.CommandInfo @@ -20,7 +20,7 @@ import GF.Infra.SIO import GF.Infra.Option import qualified System.Console.Haskeline as Haskeline -import PGF +import PGF2 import Data.Char import Data.List(isPrefixOf) @@ -274,17 +274,17 @@ importInEnv opts files = if flag optRetainResource opts then do src <- lift $ importSource opts files pgf <- lift . lazySIO $ importPGF pgf0 -- duplicates some work, better to link src - modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgfEnv pgf)} + modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgf)} else do pgf1 <- lift $ importPGF pgf0 modify $ \ gfenv->gfenv { retain=False, - pgfenv = (emptyGrammar,pgfEnv pgf1) } + pgfenv = (emptyGrammar,pgf1) } where importPGF pgf0 = do let opts' = addOptions (setOptimization OptCSE False) opts pgf1 <- importGrammar pgf0 opts' files if (verbAtLeast opts Normal) then case pgf1 of - Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf) + Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf) Nothing -> done else done return pgf1 @@ -298,10 +298,10 @@ tryGetLine = do prompt env | retain env = "> " | otherwise = case multigrammar env of - Just pgf -> showCId (abstractName pgf) ++ "> " + Just pgf -> abstractName pgf ++ "> " Nothing -> "> " -type CmdEnv = (Grammar,PGFEnv) +type CmdEnv = (Grammar,Maybe PGF) data GFEnv = GFEnv { startOpts :: Options, @@ -313,10 +313,10 @@ data GFEnv = GFEnv { emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv [] -emptyCmdEnv = (emptyGrammar,pgfEnv Nothing) +emptyCmdEnv = (emptyGrammar,Nothing) emptyCommandEnv = mkCommandEnv allCommands -multigrammar = pgf . snd . pgfenv +multigrammar = snd . pgfenv allCommands = extend pgfCommands (helpCommand allCommands:moreCommands) @@ -324,7 +324,7 @@ allCommands = `Map.union` commonCommands instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv) -instance HasPGFEnv ShellM where getPGFEnv = gets (snd . pgfenv) +instance HasPGF ShellM where getPGF = gets (snd . pgfenv) wordCompletion gfenv (left,right) = do case wc_type (reverse left) of @@ -332,17 +332,13 @@ wordCompletion gfenv (left,right) = do -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] CmplStr (Just (Command _ opts _)) s0 -> case multigrammar gfenv of - Just pgf -> let optLang opts = case valStrOpts "lang" "" opts of - "" -> case languages pgf of - [] -> Nothing - (lang:_) -> Just lang - lang -> let cla = mkCId lang in - if elem cla (languages pgf) - then Just cla - else let cla = mkCId (showCId (abstractName pgf) ++ lang) - in if elem cla (languages pgf) - then Just cla - else Nothing + Just pgf -> let langs = languages pgf + optLang opts = case valStrOpts "lang" "" opts of + "" -> case Map.minView langs of + Nothing -> Nothing + Just (concr,_) -> Just concr + lang -> mplus (Map.lookup lang langs) + (Map.lookup (abstractName pgf ++ lang) langs) optType opts = let readOpt str = case readType str of Just ty -> case checkType pgf ty of Left _ -> Nothing @@ -353,8 +349,8 @@ wordCompletion gfenv (left,right) = do s = reverse rs prefix = reverse rprefix in case (optLang opts, optType opts) of - (Just lang,Just cat) -> let (_,_,compls) = complete pgf lang cat s prefix - in ret (length prefix) (map Haskeline.simpleCompletion (Map.keys compls)) + (Just lang,Just cat) -> let compls = [t | (t,_,_,_) <- complete lang cat s prefix] + in ret (length prefix) (map Haskeline.simpleCompletion compls) _ -> ret 0 [] Nothing -> ret 0 [] CmplOpt (Just (Command n _ _)) pref @@ -368,7 +364,7 @@ wordCompletion gfenv (left,right) = do -> Haskeline.completeFilename (left,right) CmplIdent _ pref -> case multigrammar gfenv of - Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | cid <- functions pgf, let name = showCId cid, isPrefixOf pref name] + Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name] Nothing -> ret (length pref) [] _ -> ret 0 [] where diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs deleted file mode 100644 index ac8887bec..000000000 --- a/src/compiler/GF/Interactive2.hs +++ /dev/null @@ -1,445 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} --- | GF interactive mode (with the C run-time system) -module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where -import Prelude hiding (putStrLn,print) -import qualified Prelude as P(putStrLn) -import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine) -import GF.Command.Commands2(PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands) -import GF.Command.CommonCommands -import GF.Command.CommandInfo -import GF.Command.Help(helpCommand) -import GF.Command.Abstract -import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.Operations (Err(..),done) -import GF.Data.Utilities(whenM,repeatM) - -import GF.Infra.UseIO(ioErrorText,putStrLnE) -import GF.Infra.SIO -import GF.Infra.Option -import qualified System.Console.Haskeline as Haskeline ---import GF.Text.Coding(decodeUnicode,encodeUnicode) - ---import GF.Compile.Coding(codeTerm) - -import qualified PGF2 as C -import qualified PGF as H - -import Data.Char -import Data.List(isPrefixOf) -import qualified Data.Map as Map - -import qualified Text.ParserCombinators.ReadP as RP ---import System.IO(utf8) ---import System.CPUTime(getCPUTime) -import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory) -import System.FilePath(takeExtensions) -import Control.Exception(SomeException,fromException,try) ---import Control.Monad -import Control.Monad.State hiding (void) - -import qualified GF.System.Signal as IO(runInterruptibly) -{- -#ifdef SERVER_MODE -import GF.Server(server) -#endif --} - -import GF.Command.Messages(welcome) - --- | Run the GF Shell in quiet mode (@gf -run@). -mainRunGFI :: Options -> [FilePath] -> IO () -mainRunGFI opts files = shell (beQuiet opts) files - -beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) - --- | Run the interactive GF Shell -mainGFI :: Options -> [FilePath] -> IO () -mainGFI opts files = do - P.putStrLn welcome - P.putStrLn "This shell uses the C run-time system. See help for available commands." - shell opts files - -shell opts files = flip evalStateT (emptyGFEnv opts) $ - do mapStateT runSIO $ importInEnv opts files - loop - -{- -#ifdef SERVER_MODE --- | Run the GF Server (@gf -server@). --- The 'Int' argument is the port number for the HTTP service. -mainServerGFI opts0 port files = - server jobs port root (execute1 opts) - =<< runSIO (importInEnv (emptyGFEnv opts) opts files) - where - root = flag optDocumentRoot opts - opts = beQuiet opts0 - jobs = join (flag optJobs opts) -#else -mainServerGFI opts port files = - error "GF has not been compiled with server mode support" -#endif --} --- | Read end execute commands until it is time to quit -loop :: StateT GFEnv IO () -loop = repeatM readAndExecute1 - --- | Read and execute one command, returning 'True' to continue execution, --- | 'False' when it is time to quit -readAndExecute1 :: StateT GFEnv IO Bool -readAndExecute1 = mapStateT runSIO . execute1 =<< readCommand - --- | Read a command -readCommand :: StateT GFEnv IO String -readCommand = - do opts <- gets startOpts - case flag optMode opts of - ModeRun -> lift tryGetLine - _ -> lift . fetchCommand =<< get - -timeIt act = - do t1 <- liftSIO $ getCPUTime - a <- act - t2 <- liftSIO $ getCPUTime - return (t2-t1,a) - --- | Optionally show how much CPU time was used to run an IO action -optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a -optionallyShowCPUTime opts act - | not (verbAtLeast opts Normal) = act - | otherwise = do (dt,r) <- timeIt act - liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec" - return r - -type ShellM = StateT GFEnv SIO - --- | Execute a given command line, returning 'True' to continue execution, --- | 'False' when it is time to quit -execute1 :: String -> ShellM Bool -execute1 s0 = - do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0} - execute1' s0 - --- | Execute a given command line, without adding it to the history -execute1' s0 = - do opts <- gets startOpts - interruptible $ optionallyShowCPUTime opts $ - case pwords s0 of - -- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands - -- special commands - "q" :_ -> quit - "!" :ws -> system_command ws - "eh":ws -> execute_history ws - "i" :ws -> do import_ ws; continue - -- other special commands, working on GFEnv - "dc":ws -> define_command ws - "dt":ws -> define_tree ws - -- ordinary commands - _ -> do env <- gets commandenv - interpretCommandLine env s0 - continue - where - continue,stop :: ShellM Bool - continue = return True - stop = return False - - interruptible :: ShellM Bool -> ShellM Bool - interruptible act = - do gfenv <- get - mapStateT ( - either (\e -> printException e >> return (True,gfenv)) return - <=< runInterruptibly) act - - -- Special commands: - - quit = do opts <- gets startOpts - when (verbAtLeast opts Normal) $ putStrLnE "See you." - stop - - system_command ws = do lift $ restrictedSystem $ unwords ws ; continue - - - {-"eh":w:_ -> do - cs <- readFile w >>= return . map words . lines - gfenv' <- foldM (flip (process False benv)) gfenv cs - loopNewCPU gfenv' -} - execute_history [w] = - do execute . lines =<< lift (restricted (readFile w)) - continue - where - execute :: [String] -> ShellM () - execute [] = done - execute (line:lines) = whenM (execute1' line) (execute lines) - - execute_history _ = - do putStrLnE "eh command not parsed" - continue - - define_command (f:ws) = - case readCommandLine (unwords ws) of - Just comm -> - do modify $ - \ gfenv -> - let env = commandenv gfenv - in gfenv { - commandenv = env { - commandmacros = Map.insert f comm (commandmacros env) - } - } - continue - _ -> dc_not_parsed - define_command _ = dc_not_parsed - - dc_not_parsed = putStrLnE "command definition not parsed" >> continue - - define_tree (f:ws) = - case H.readExpr (unwords ws) of - Just exp -> - do modify $ - \ gfenv -> - let env = commandenv gfenv - in gfenv { commandenv = env { - expmacros = Map.insert f exp (expmacros env) } } - continue - _ -> dt_not_parsed - define_tree _ = dt_not_parsed - - dt_not_parsed = putStrLnE "value definition not parsed" >> continue - -pwords s = case words s of - w:ws -> getCommandOp w :ws - ws -> ws -import_ args = - do case parseOptions args of - Ok (opts',files) -> do - opts <- gets startOpts - curr_dir <- lift getCurrentDirectory - lib_dir <- lift $ getLibraryDirectory (addOptions opts opts') - importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files - Bad err -> - do putStrLnE $ "Command parse error: " ++ err - --- | Commands that work on 'GFEnv' -moreCommands = [ - ("e", emptyCommandInfo { - longname = "empty", - synopsis = "empty the environment (except the command history)", - exec = \ _ _ -> - do modify $ \ gfenv -> (emptyGFEnv (startOpts gfenv)) - { history=history gfenv } - return void - }), - ("ph", emptyCommandInfo { - longname = "print_history", - synopsis = "print command history", - explanation = unlines [ - "Prints the commands issued during the GF session.", - "The result is readable by the eh command.", - "The result can be used as a script when starting GF." - ], - examples = [ - mkEx "ph | wf -file=foo.gfs -- save the history into a file" - ], - exec = \ _ _ -> - fmap (fromString . unlines . reverse . drop 1 . history) get - }), - ("r", emptyCommandInfo { - longname = "reload", - synopsis = "repeat the latest import command", - exec = \ _ _ -> - do gfenv0 <- get - let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]] - case imports of - (s,ws):_ -> do - putStrLnE $ "repeating latest import: " ++ s - import_ ws - _ -> do - putStrLnE $ "no import in history" - return void - }) - ] - - -printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e) - -fetchCommand :: GFEnv -> IO String -fetchCommand gfenv = do - path <- getAppUserDataDirectory "gf_history" - let settings = - Haskeline.Settings { - Haskeline.complete = wordCompletion gfenv, - Haskeline.historyFile = Just path, - Haskeline.autoAddHistory = True - } - res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt gfenv)) - case res of - Left _ -> return "" - Right Nothing -> return "q" - Right (Just s) -> return s - -importInEnv :: Options -> [FilePath] -> ShellM () -importInEnv opts files = - case files of - _ | flag optRetainResource opts -> - putStrLnE "Flag -retain is not supported in this shell" - [file] | takeExtensions file == ".pgf" -> importPGF file - [] -> done - _ -> do putStrLnE "Can only import one .pgf file" - where - importPGF file = - do gfenv <- get - case multigrammar gfenv of - Just _ -> putStrLnE "Discarding previous grammar" - _ -> done - pgf1 <- lift $ readPGF2 file - let gfenv' = gfenv { pgfenv = pgfEnv pgf1 } - when (verbAtLeast opts Normal) $ - let langs = Map.keys . concretes $ gfenv' - in putStrLnE . unwords $ "\nLanguages:":langs - put gfenv' - -tryGetLine = do - res <- try getLine - case res of - Left (e :: SomeException) -> return "q" - Right l -> return l - -prompt env = abs ++ "> " - where - abs = maybe "" C.abstractName (multigrammar env) - -data GFEnv = GFEnv { - startOpts :: Options, - --grammar :: (), -- gfo grammar -retain - --retain :: (), -- grammar was imported with -retain flag - pgfenv :: PGFEnv, - commandenv :: CommandEnv ShellM, - history :: [String] - } - -emptyGFEnv opts = GFEnv opts {-() ()-} emptyPGFEnv emptyCommandEnv [] - -emptyCommandEnv = mkCommandEnv allCommands -multigrammar = pgf . pgfenv -concretes = concs . pgfenv - -allCommands = - extend pgfCommands (helpCommand allCommands:moreCommands) - `Map.union` commonCommands - -instance HasPGFEnv ShellM where getPGFEnv = gets pgfenv - --- ** Completion - -wordCompletion gfenv (left,right) = do - case wc_type (reverse left) of - CmplCmd pref - -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] -{- - CmplStr (Just (Command _ opts _)) s0 - -> do mb_state0 <- try (evaluate (H.initState pgf (optLang opts) (optType opts))) - case mb_state0 of - Right state0 -> let (rprefix,rs) = break isSpace (reverse s0) - s = reverse rs - prefix = reverse rprefix - ws = words s - in case loop state0 ws of - Nothing -> ret 0 [] - Just state -> let compls = H.getCompletions state prefix - in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls)) - Left (_ :: SomeException) -> ret 0 [] --} - CmplOpt (Just (Command n _ _)) pref - -> case Map.lookup n (commands cmdEnv) of - Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg] - opt_compls = [Haskeline.Completion ('-':opt) ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt] - ret (length pref+1) - (flg_compls++opt_compls) - Nothing -> ret (length pref) [] - CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i - -> Haskeline.completeFilename (left,right) - - CmplIdent _ pref - -> case mb_pgf of - Just pgf -> ret (length pref) - [Haskeline.simpleCompletion name - | name <- C.functions pgf, - isPrefixOf pref name] - _ -> ret (length pref) [] - - _ -> ret 0 [] - where - mb_pgf = multigrammar gfenv - cmdEnv = commandenv gfenv -{- - optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts - optType opts = - let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts - in case H.readType str of - Just ty -> ty - Nothing -> error ("Can't parse '"++str++"' as type") - - loop ps [] = Just ps - loop ps (t:ts) = case H.nextState ps (H.simpleParseInput t) of - Left es -> Nothing - Right ps -> loop ps ts --} - ret len xs = return (drop len left,xs) - - -data CompletionType - = CmplCmd Ident - | CmplStr (Maybe Command) String - | CmplOpt (Maybe Command) Ident - | CmplIdent (Maybe Command) Ident - deriving Show - -wc_type :: String -> CompletionType -wc_type = cmd_name - where - cmd_name cs = - let cs1 = dropWhile isSpace cs - in go cs1 cs1 - where - go x [] = CmplCmd x - go x (c:cs) - | isIdent c = go x cs - | otherwise = cmd x cs - - cmd x [] = ret CmplIdent x "" 0 - cmd _ ('|':cs) = cmd_name cs - cmd _ (';':cs) = cmd_name cs - cmd x ('"':cs) = str x cs cs - cmd x ('-':cs) = option x cs cs - cmd x (c :cs) - | isIdent c = ident x (c:cs) cs - | otherwise = cmd x cs - - option x y [] = ret CmplOpt x y 1 - option x y ('=':cs) = optValue x y cs - option x y (c :cs) - | isIdent c = option x y cs - | otherwise = cmd x cs - - optValue x y ('"':cs) = str x y cs - optValue x y cs = cmd x cs - - ident x y [] = ret CmplIdent x y 0 - ident x y (c:cs) - | isIdent c = ident x y cs - | otherwise = cmd x cs - - str x y [] = ret CmplStr x y 1 - str x y ('\"':cs) = cmd x cs - str x y ('\\':c:cs) = str x y cs - str x y (c:cs) = str x y cs - - ret f x y d = f cmd y - where - x1 = take (length x - length y - d) x - x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 - - cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x - _ -> Nothing - - isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GF/Quiz.hs b/src/compiler/GF/Quiz.hs index 2aed598d1..7da485db0 100644 --- a/src/compiler/GF/Quiz.hs +++ b/src/compiler/GF/Quiz.hs @@ -18,13 +18,8 @@ module GF.Quiz ( morphologyList ) where -import PGF ---import PGF.Linearize +import PGF2 import GF.Data.Operations ---import GF.Infra.UseIO ---import GF.Infra.Option ---import PGF.Probabilistic - import System.Random import Data.List (nub) @@ -38,7 +33,7 @@ mkQuiz msg tts = do teachDialogue qas msg translationList :: - Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] + Maybe Expr -> PGF -> Concr -> Concr -> Type -> Int -> IO [(String,[String])] translationList mex pgf ig og typ number = do gen <- newStdGen let ts = take number $ case mex of @@ -46,19 +41,22 @@ translationList mex pgf ig og typ number = do Nothing -> generateRandom gen pgf typ return $ map mkOne $ ts where - mkOne t = (norml (linearize pgf ig t), + mkOne t = (norml (linearize ig t), map norml (concatMap lins (homonyms t))) - homonyms = parse pgf ig typ . linearize pgf ig - lins = nub . concatMap (map snd) . tabularLinearizes pgf og + homonyms t = + case (parse ig typ . linearize ig) t of + ParseOk res -> map fst res + _ -> [] + lins = nub . concatMap (map snd) . tabularLinearizeAll og morphologyList :: - Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])] + Maybe Expr -> PGF -> Concr -> Type -> Int -> IO [(String,[String])] morphologyList mex pgf ig typ number = do gen <- newStdGen let ts = take (max 1 number) $ case mex of Just ex -> generateRandomFrom gen pgf ex Nothing -> generateRandom gen pgf typ - let ss = map (tabularLinearizes pgf ig) ts + let ss = map (tabularLinearizeAll ig) ts let size = length (head (head ss)) let forms = take number $ randomRs (0,size-1) gen return [(snd (head pws0) +++ fst (pws0 !! i), ws) | diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index 477f41e7c..e67944585 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -42,7 +42,6 @@ import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn) import GF.Infra.SIO(captureSIO) import GF.Data.Utilities(apSnd,mapSnd) import qualified PGFService as PS -import qualified ExampleService as ES import Data.Version(showVersion) import Paths_gf(getDataDir,version) import GF.Infra.BuildInfo (buildInfo) @@ -170,7 +169,6 @@ handle logLn documentroot state0 cache execute1 stateVar (_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path wrapCGI $ PS.cgiMain' cache path (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) - (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (PS.pgfCache cache) _ -> serveStaticFile rpath path where path = translatePath rpath _ -> return $ resp400 upath diff --git a/src/compiler/GF/Speech/CFGToFA.hs b/src/compiler/GF/Speech/CFGToFA.hs index 0a530e594..08b966354 100644 --- a/src/compiler/GF/Speech/CFGToFA.hs +++ b/src/compiler/GF/Speech/CFGToFA.hs @@ -14,7 +14,6 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import PGF.Internal import GF.Data.Utilities import GF.Grammar.CFG --import GF.Speech.PGFToCFG diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs index d9d6af0cc..b1e9b8445 100644 --- a/src/compiler/GF/Speech/GSL.hs +++ b/src/compiler/GF/Speech/GSL.hs @@ -8,13 +8,11 @@ module GF.Speech.GSL (gslPrinter) where ---import GF.Data.Utilities import GF.Grammar.CFG import GF.Speech.SRG import GF.Speech.RegExp import GF.Infra.Option ---import GF.Infra.Ident -import PGF +import PGF2 import Data.Char (toUpper,toLower) import Data.List (partition) @@ -23,7 +21,7 @@ import GF.Text.Pretty width :: Int width = 75 -gslPrinter :: Options -> PGF -> CId -> String +gslPrinter :: Options -> PGF -> Concr -> String gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc where st = style { lineLength = width } diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs index 25168dbc8..4fad08afd 100644 --- a/src/compiler/GF/Speech/JSGF.hs +++ b/src/compiler/GF/Speech/JSGF.hs @@ -18,7 +18,7 @@ import GF.Grammar.CFG import GF.Speech.RegExp import GF.Speech.SISR import GF.Speech.SRG -import PGF +import PGF2 import Data.Char import Data.List @@ -30,8 +30,8 @@ width :: Int width = 75 jsgfPrinter :: Options - -> PGF - -> CId -> String + -> PGF + -> Concr -> String jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc where st = style { lineLength = width } sisr = flag optSISR opts diff --git a/src/compiler/GF/Speech/PrRegExp.hs b/src/compiler/GF/Speech/PrRegExp.hs index 2829839f3..246d7ce3d 100644 --- a/src/compiler/GF/Speech/PrRegExp.hs +++ b/src/compiler/GF/Speech/PrRegExp.hs @@ -11,12 +11,12 @@ import GF.Grammar.CFG import GF.Speech.CFGToFA import GF.Speech.PGFToCFG import GF.Speech.RegExp -import PGF +import PGF2 -regexpPrinter :: PGF -> CId -> String +regexpPrinter :: PGF -> Concr -> String regexpPrinter pgf cnc = (++"\n") $ prRE id $ dfa2re $ cfgToFA $ pgfToCFG pgf cnc -multiRegexpPrinter :: PGF -> CId -> String +multiRegexpPrinter :: PGF -> Concr -> String multiRegexpPrinter pgf cnc = prREs $ mfa2res $ cfgToMFA $ pgfToCFG pgf cnc prREs :: [(String,RE CFSymbol)] -> String diff --git a/src/compiler/GF/Speech/SISR.hs b/src/compiler/GF/Speech/SISR.hs index 5f9161547..452984c00 100644 --- a/src/compiler/GF/Speech/SISR.hs +++ b/src/compiler/GF/Speech/SISR.hs @@ -10,13 +10,9 @@ module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR, import Data.List ---import GF.Data.Utilities ---import GF.Infra.Ident import GF.Infra.Option (SISRFormat(..)) import GF.Grammar.CFG import GF.Speech.SRG (SRGNT) -import PGF(showCId) - import qualified GF.JavaScript.AbsJS as JS import qualified GF.JavaScript.PrintJS as JS @@ -50,12 +46,12 @@ catSISR t (c,i) fmt profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term] where - f (CFObj n ts) = tree (showCId n) (map f ts) + f (CFObj n ts) = tree n (map f ts) f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)] f (CFApp x y) = JS.ECall (f x) [f y] f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i)) f (CFVar v) = JS.EVar (var v) - f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (showCId typ))] + f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr typ)] fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$") fmtOut SISR_1_0 = JS.EVar (JS.Ident "out") diff --git a/src/compiler/GF/Speech/SLF.hs b/src/compiler/GF/Speech/SLF.hs index 16f8f0461..fd54c4e84 100644 --- a/src/compiler/GF/Speech/SLF.hs +++ b/src/compiler/GF/Speech/SLF.hs @@ -16,17 +16,14 @@ module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter, import GF.Data.Utilities import GF.Grammar.CFG import GF.Speech.FiniteState ---import GF.Speech.CFG import GF.Speech.CFGToFA import GF.Speech.PGFToCFG import qualified GF.Data.Graphviz as Dot -import PGF ---import PGF.CId +import PGF2 import Control.Monad import qualified Control.Monad.State as STM import Data.Char (toUpper) ---import Data.List import Data.Maybe data SLFs = SLFs [(String,SLF)] SLF @@ -43,7 +40,7 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int } type SLF_FA = FA State (Maybe CFSymbol) () -mkFAs :: PGF -> CId -> (SLF_FA, [(String,SLF_FA)]) +mkFAs :: PGF -> Concr -> (SLF_FA, [(String,SLF_FA)]) mkFAs pgf cnc = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) where MFA start subs = {- renameSubs $ -} cfgToMFA $ pgfToCFG pgf cnc main = let (fa,s,f) = newFA_ in newTransition s f (NonTerminal start) fa @@ -64,7 +61,7 @@ renameSubs (MFA start subs) = MFA (newName start) subs' -- * SLF graphviz printing (without sub-networks) -- -slfGraphvizPrinter :: PGF -> CId -> String +slfGraphvizPrinter :: PGF -> Concr -> String slfGraphvizPrinter pgf cnc = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc where @@ -74,7 +71,7 @@ slfGraphvizPrinter pgf cnc -- * SLF graphviz printing (with sub-networks) -- -slfSubGraphvizPrinter :: PGF -> CId -> String +slfSubGraphvizPrinter :: PGF -> Concr -> String slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g where (main, subs) = mkFAs pgf cnc g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] @@ -100,7 +97,7 @@ gvSLFFA n fa = -- * SLF printing (without sub-networks) -- -slfPrinter :: PGF -> CId -> String +slfPrinter :: PGF -> Concr -> String slfPrinter pgf cnc = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc @@ -109,7 +106,7 @@ slfPrinter pgf cnc -- -- | Make a network with subnetworks in SLF -slfSubPrinter :: PGF -> CId -> String +slfSubPrinter :: PGF -> Concr -> String slfSubPrinter pgf cnc = prSLFs slfs where (main,subs) = mkFAs pgf cnc diff --git a/src/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs index 9d51e52e9..20eb32225 100644 --- a/src/compiler/GF/Speech/SRG.hs +++ b/src/compiler/GF/Speech/SRG.hs @@ -17,21 +17,15 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol , lookupFM_ ) where ---import GF.Data.Operations +import PGF2 import GF.Data.Utilities ---import GF.Infra.Ident import GF.Infra.Option import GF.Grammar.CFG import GF.Speech.PGFToCFG ---import GF.Data.Relation ---import GF.Speech.FiniteState import GF.Speech.RegExp import GF.Speech.CFGToFA ---import GF.Infra.Option -import PGF import Data.List ---import Data.Maybe (fromMaybe, maybeToList) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -62,16 +56,16 @@ type SRGSymbol = Symbol SRGNT Token -- | An SRG non-terminal. Category name and its number in the profile. type SRGNT = (Cat, Int) -ebnfPrinter :: Options -> PGF -> CId -> String +ebnfPrinter :: Options -> PGF -> Concr -> String ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc -- | Create a compact filtered non-left-recursive SRG. -makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG +makeNonLeftRecursiveSRG :: Options -> PGF -> Concr -> SRG makeNonLeftRecursiveSRG opts = makeSRG opts' where opts' = setDefaultCFGTransform opts CFGNoLR True -makeSRG :: Options -> PGF -> CId -> SRG +makeSRG :: Options -> PGF -> Concr -> SRG makeSRG opts = mkSRG cfgToSRG preprocess where cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg] @@ -97,7 +91,7 @@ stats g = "Categories: " ++ show (countCats g) -} makeNonRecursiveSRG :: Options -> PGF - -> CId -- ^ Concrete syntax name. + -> Concr -> SRG makeNonRecursiveSRG opts = mkSRG cfgToSRG id where @@ -105,17 +99,17 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id where MFA _ dfas = cfgToMFA cfg dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re - dummyCFTerm = CFMeta (mkCId "dummy") + dummyCFTerm = CFMeta "dummy" dummySRGNT = mapSymbol (\c -> (c,0)) id -mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG +mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> Concr -> SRG mkSRG mkRules preprocess pgf cnc = - SRG { srgName = showCId cnc, - srgStartCat = cfgStartCat cfg, + SRG { srgName = concreteName cnc, + srgStartCat = cfgStartCat cfg, srgExternalCats = cfgExternalCats cfg, - srgLanguage = languageCode pgf cnc, + srgLanguage = languageCode cnc, srgRules = mkRules cfg } - where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc + where cfg = renameCats (concreteName cnc) $ preprocess $ pgfToCFG pgf cnc -- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), -- to C_N where N is an integer. diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs index 75d206a0c..831a25dd2 100644 --- a/src/compiler/GF/Speech/SRGS_ABNF.hs +++ b/src/compiler/GF/Speech/SRGS_ABNF.hs @@ -25,23 +25,21 @@ import GF.Grammar.CFG import GF.Speech.SISR as SISR import GF.Speech.SRG import GF.Speech.RegExp -import PGF (PGF, CId) +import PGF2 (PGF,Concr) ---import Data.Char import Data.List import Data.Maybe import GF.Text.Pretty ---import Debug.Trace width :: Int width = 75 srgsAbnfPrinter :: Options - -> PGF -> CId -> String + -> PGF -> Concr -> String srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc where sisr = flag optSISR opts -srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String +srgsAbnfNonRecursivePrinter :: Options -> PGF -> Concr -> String srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc showDoc = renderStyle (style { lineLength = width }) diff --git a/src/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs index 397bfb739..60b3c1138 100644 --- a/src/compiler/GF/Speech/SRGS_XML.hs +++ b/src/compiler/GF/Speech/SRGS_XML.hs @@ -13,7 +13,7 @@ import GF.Grammar.CFG import GF.Speech.RegExp import GF.Speech.SISR as SISR import GF.Speech.SRG -import PGF (PGF, CId, Token) +import PGF2 (PGF, Concr) --import Control.Monad --import Data.Char (toUpper,toLower) @@ -22,11 +22,11 @@ import Data.Maybe --import qualified Data.Map as Map srgsXmlPrinter :: Options - -> PGF -> CId -> String + -> PGF -> Concr -> String srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc where sisr = flag optSISR opts -srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String +srgsXmlNonRecursivePrinter :: Options -> PGF -> Concr -> String srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs index d05ba27ce..e627693f1 100644 --- a/src/compiler/GF/Speech/VoiceXML.hs +++ b/src/compiler/GF/Speech/VoiceXML.hs @@ -6,14 +6,8 @@ ----------------------------------------------------------------------------- module GF.Speech.VoiceXML (grammar2vxml) where ---import GF.Data.Operations ---import GF.Data.Str (sstrV) ---import GF.Data.Utilities import GF.Data.XML ---import GF.Infra.Ident -import PGF - ---import Control.Monad (liftM) +import PGF2 import Data.List (intersperse) -- isPrefixOf, find import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -21,19 +15,19 @@ import Data.Maybe (fromMaybe) --import Debug.Trace -- | the main function -grammar2vxml :: PGF -> CId -> String -grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) "" +grammar2vxml :: PGF -> Concr -> String +grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name mb_language start skel qs) "" where skel = pgfSkeleton pgf - name = showCId cnc - qs = catQuestions pgf cnc (map fst skel) - language = languageCode pgf cnc + name = concreteName cnc + qs = catQuestions cnc (map fst skel) + mb_language = languageCode cnc (_,start,_) = unType (startCat pgf) -- -- * VSkeleton: a simple description of the abstract syntax. -- -type Skeleton = [(CId, [(CId, [CId])])] +type Skeleton = [(Cat, [(Fun, [Cat])])] pgfSkeleton :: PGF -> Skeleton pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) | f <- functionsByCat pgf c, Just (hypos,_,_) <- [fmap unType (functionType pgf f)]]) @@ -43,37 +37,23 @@ pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) -- * Questions to ask -- -type CatQuestions = [(CId,String)] +type CatQuestions = [(Cat,String)] -catQuestions :: PGF -> CId -> [CId] -> CatQuestions -catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats] +catQuestions :: Concr -> [Cat] -> CatQuestions +catQuestions cnc cats = [(c,catQuestion cnc c) | c <- cats] -catQuestion :: PGF -> CId -> CId -> String -catQuestion pgf cnc cat = showPrintName pgf cnc cat +catQuestion :: Concr -> Cat -> String +catQuestion cnc cat = fromMaybe cat (printName cnc cat) - -{- -lin :: StateGrammar -> String -> Err String -lin gr fun = do - tree <- string2treeErr gr fun - let ls = map unt $ linTree2strings noMark g c tree - case ls of - [] -> fail $ "No linearization of " ++ fun - l:_ -> return l - where c = cncId gr - g = stateGrammarST gr - unt = formatAsText --} - -getCatQuestion :: CId -> CatQuestions -> String +getCatQuestion :: Cat -> CatQuestions -> String getCatQuestion c qs = - fromMaybe (error "No question for category " ++ showCId c) (lookup c qs) + fromMaybe (error "No question for category " ++ c) (lookup c qs) -- -- * Generate VoiceXML -- -skel2vxml :: String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML +skel2vxml :: String -> Maybe String -> Cat -> Skeleton -> CatQuestions -> XML skel2vxml name language start skel qs = vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel) where @@ -85,12 +65,12 @@ grammarURI :: String -> String grammarURI name = name ++ ".grxml" -catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML] +catForms :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> [XML] catForms gr qs cat fs = - comments [showCId cat ++ " category."] + comments [cat ++ " category."] ++ [cat2form gr qs cat fs] -cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML +cat2form :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> XML cat2form gr qs cat fs = form (catFormId cat) $ [var "old" Nothing, @@ -103,22 +83,22 @@ cat2form gr qs cat fs = ++ concatMap (uncurry (fun2sub gr cat)) fs ++ [block [return_ ["term"]{-]-}]] -fun2sub :: String -> CId -> CId -> [CId] -> [XML] +fun2sub :: String -> Cat -> Fun -> [Cat] -> [XML] fun2sub gr cat fun args = - comments [showCId fun ++ " : (" - ++ concat (intersperse ", " (map showCId args)) - ++ ") " ++ showCId cat] ++ ss + comments [fun ++ " : (" + ++ concat (intersperse ", " args) + ++ ") " ++ cat] ++ ss where ss = zipWith mkSub [0..] args mkSub n t = subdialog s [("src","#"++catFormId t), - ("cond","term.name == "++string (showCId fun))] + ("cond","term.name == "++string fun)] [param "old" v, filled [] [assign v (s++".term")]] - where s = showCId fun ++ "_" ++ show n + where s = fun ++ "_" ++ show n v = "term.args["++show n++"]" -catFormId :: CId -> String -catFormId c = showCId c ++ "_cat" +catFormId :: Cat -> String +catFormId c = c ++ "_cat" -- diff --git a/src/compiler/GF/Text/Lexing.hs b/src/compiler/GF/Text/Lexing.hs index 7195daacd..42fe3eec1 100644 --- a/src/compiler/GF/Text/Lexing.hs +++ b/src/compiler/GF/Text/Lexing.hs @@ -15,7 +15,6 @@ stringOp good name = case name of "lexgreek" -> Just $ appLexer lexAGreek "lexgreek2" -> Just $ appLexer lexAGreek2 "words" -> Just $ appLexer words - "bind" -> Just $ appUnlexer (unwords . bindTok) "unchars" -> Just $ appUnlexer concat "unlextext" -> Just $ appUnlexer (unlexText . unquote . bindTok) "unlexcode" -> Just $ appUnlexer unlexCode diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs index 3ab1a131b..491a7a5b3 100644 --- a/src/compiler/SimpleEditor/Convert.hs +++ b/src/compiler/SimpleEditor/Convert.hs @@ -17,7 +17,7 @@ import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..)) import GF.Grammar.Parser(runP,pModDef) import GF.Grammar.Lexer(Posn(..)) import GF.Data.ErrM -import PGF.Internal(Literal(LStr)) +import PGF2.Internal(Literal(LStr)) import SimpleEditor.Syntax as S import SimpleEditor.JSON diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c index 26ea6cfb7..5acab162e 100644 --- a/src/runtime/c/pgf/pgf.c +++ b/src/runtime/c/pgf/pgf.c @@ -227,7 +227,7 @@ pgf_language_code(PgfConcr* concr) gu_seq_binsearch(concr->cflags, pgf_flag_order, PgfFlag, "language"); if (flag == NULL) - return ""; + return NULL; GuVariantInfo i = gu_variant_open(flag->value); switch (i.tag) { @@ -237,7 +237,7 @@ pgf_language_code(PgfConcr* concr) } } - return ""; + return NULL; } PGF_API void diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 38ef3a07d..40228f9da 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -57,19 +57,24 @@ module PGF2 (-- * PGF linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize, FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString, printName, + alignWords, gizaAlignment, - alignWords, -- ** Parsing ParseOutput(..), parse, parseWithHeuristics, complete, + -- ** Sentence Lookup lookupSentence, + -- ** Generation - generateAll, + generateAll, generateAllFrom, + generateRandom, generateRandomFrom, + -- ** Morphological Analysis MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon, -- ** Visualizations GraphvizOptions(..), graphvizDefaults, graphvizAbstractTree, graphvizParseTree, + Labels, getDepLabels, graphvizDependencyTree, conlls2latexDoc, getCncDepLabels, graphvizWordAlignment, @@ -77,13 +82,17 @@ module PGF2 (-- * PGF PGFError(..), -- * Grammar specific callbacks - LiteralCallback,literalCallbacks + LiteralCallback,literalCallbacks, + + -- * Auxiliaries + readProbabilitiesFromFile ) where import Prelude hiding (fromEnum) import Control.Exception(Exception,throwIO) import Control.Monad(forM_) import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) +import System.Random import Text.PrettyPrint import PGF2.Expr import PGF2.Type @@ -171,9 +180,12 @@ languages p = langs p concreteName :: Concr -> ConcName concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c)) -languageCode :: Concr -> String -languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c)) - +languageCode :: Concr -> Maybe String +languageCode c = unsafePerformIO $ do + c_code <- pgf_language_code (concr c) + if c_code == nullPtr + then return Nothing + else fmap Just (peekUtf8CString c_code) -- | Generates an exhaustive possibly infinite list of -- all abstract syntax expressions of the given type. @@ -189,6 +201,15 @@ generateAll p (Type ctype _) = exprFPl <- newForeignPtr gu_pool_finalizer exprPl fromPgfExprEnum enum genFPl (touchPGF p >> touchForeignPtr exprFPl) +generateAllFrom :: PGF -> Expr -> [(Expr,Float)] +generateAllFrom = error "generateAllFrom is not implemented yet" + +generateRandom :: RandomGen gen => gen -> PGF -> Type -> [a] +generateRandom = error "generateRandom is not implemented yet" + +generateRandomFrom :: RandomGen gen => gen -> PGF -> Expr -> [a] +generateRandomFrom = error "generateRandomFrom is not implemented yet" + -- | The abstract language name is the name of the top-level -- abstract module abstractName :: PGF -> AbsName @@ -448,6 +469,9 @@ graphvizWordAlignment cs opts e = type Labels = Map.Map Fun [String] +getDepLabels :: String -> Labels +getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)] + -- | Visualize word dependency tree. graphvizDependencyTree :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@ @@ -1499,6 +1523,8 @@ alignWords lang e = unsafePerformIO $ (fids :: [CInt]) <- peekArray (fromIntegral (n_fids :: CInt)) (ptr `plusPtr` (#offset PgfAlignmentPhrase, fids)) return (phrase, map fromIntegral fids) +gizaAlignment = error "gizaAlignment is not implemented" + printName :: Concr -> Fun -> Maybe String printName lang fun = unsafePerformIO $ @@ -1729,3 +1755,9 @@ capitalized' not s = Nothing tag i | i < 0 = char 'r' <> int (negate i) | otherwise = char 'n' <> int i + + +readProbabilitiesFromFile :: FilePath -> IO (Map.Map String Double) +readProbabilitiesFromFile fpath = do + s <- readFile fpath + return $ Map.fromList [(f,read p) | f:p:_ <- map words (lines s)] diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index 09b7cbb46..bb1813bcb 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -18,7 +18,7 @@ library -- backwards compatibility API: PGF, PGF.Internal other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI - build-depends: base >=4.3, containers, pretty, array + build-depends: base >=4.3, containers, pretty, array, random -- hs-source-dirs: default-language: Haskell2010 build-tools: hsc2hs diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index c3223a827..fc493d683 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -2285,7 +2285,10 @@ Concr_getName(ConcrObject *self, void *closure) static PyObject* Concr_getLanguageCode(ConcrObject *self, void *closure) { - return PyString_FromString(pgf_language_code(self->concr)); + GuString code = pgf_language_code(self->concr); + if (code == NULL) + Py_RETURN_NONE; + return PyString_FromString(code); } static PyObject* diff --git a/src/server/transfer/Fold.hs b/src/server/transfer/Fold.hs index 61f0d4b34..bd1e1fe17 100644 --- a/src/server/transfer/Fold.hs +++ b/src/server/transfer/Fold.hs @@ -1,14 +1,15 @@ module Fold where -import PGF + +import PGF2 import Data.Map as M (lookup, fromList) --import Debug.Trace -foldable = fromList [(mkCId c, mkCId ("bin_" ++ c)) | c <- ops] +foldable = fromList [(c, "bin_" ++ c) | c <- ops] where ops = words "plus times and or xor cartesian_product intersect union" -fold :: Tree -> Tree +fold :: Expr -> Expr fold t = case unApp t of Just (i,[x]) -> @@ -18,9 +19,9 @@ fold t = Just (i,xs) -> mkApp i $ map fold xs _ -> t -appFold :: CId -> Tree -> Tree +appFold :: Fun -> Expr -> Expr appFold j t = case unApp t of Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts] Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s] - where isPre i s = take 4 (show i) == s \ No newline at end of file + where isPre i s = take 4 (show i) == s