diff options
Diffstat (limited to 'src/compiler')
| -rw-r--r-- | src/compiler/GF/Command/Commands2.hs | 146 |
1 files changed, 59 insertions, 87 deletions
diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs index 7fe28ca8d..c8e6fbff3 100644 --- a/src/compiler/GF/Command/Commands2.hs +++ b/src/compiler/GF/Command/Commands2.hs @@ -7,44 +7,17 @@ import Prelude hiding (putStrLn) import PGF2 import qualified PGF as H - ---import qualified PGF.Internal as H(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin) -import qualified PGF.Internal as H(Expr(EFun)) ----abstract,funs,cats, ---import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ---- ---import qualified PGF.Internal as H(ppFun,ppCat) - ---import qualified PGF.Internal as H(optimizePGF) - ---import GF.Compile.Export import GF.Compile.ToAPI(exprToAPI) ---import GF.Compile.ExampleBased ---import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl) import GF.Infra.UseIO(writeUTF8File) import GF.Infra.SIO(MonadSIO,liftSIO,putStrLn,restricted,restrictedSystem) ---import GF.Data.ErrM ---- import GF.Command.Abstract ---import GF.Command.Messages import GF.Command.CommandInfo ---import GF.Text.Lexing ---import GF.Text.Clitics ---import GF.Text.Transliterations ---import GF.Quiz - ---import GF.Command.TreeOperations ---- temporary place for typecheck and compute - import GF.Data.Operations - ---import PGF.Internal (encodeFile) -import Data.List(intersperse,nub) +import Data.List(intersperse,intersect,nub,sortBy) import Data.Maybe import qualified Data.Map as Map ---import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead! ---import GF.System.Process import GF.Text.Pretty ---import Data.List (sort) import Control.Monad(mplus) ---import Debug.Trace ---import System.Random (newStdGen) ---- data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr} @@ -54,8 +27,13 @@ emptyPGFEnv = Env Nothing Map.empty class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv -instance Monad m => TypeCheckArg m where - typeCheckArg = return -- no type checker available !! +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 [ @@ -72,30 +50,29 @@ pgfCommands = Map.fromList [ ], exec = needPGF $ \opts es env -> do let cncs = optConcs env opts - {-if isOpt "giza" opts - then do - let giz = map (H.gizaAlignment pgf (head $ langs, head $ tail $ langs)) es - let lsrc = unlines $ map (\(x,_,_) -> x) giz - let ltrg = unlines $ map (\(_,x,_) -> x) giz - let align = unlines $ map (\(_,_,x) -> x) giz - 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-} - do 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))) - 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, + 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"), @@ -395,7 +372,6 @@ pgfCommands = Map.fromList [ _ -> return (fromString s), flags = [("file","the input file name")] }), -{- ("rt", emptyCommandInfo { longname = "rank_trees", synopsis = "show trees in an order of decreasing probability", @@ -405,14 +381,14 @@ pgfCommands = Map.fromList [ "by the file given by flag -probs=FILE, where each line has the form", "'function probability', e.g. 'youPol_Pron 0.01'." ], - exec = \env@(pgf, mos) opts ts -> do - pgf <- optProbs opts pgf - let tds = H.rankTreesByProbs pgf ts + 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 [H.showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] + unlines [PGF2.showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] else return () - returnFromExprs $ map fst tds, + returnFromExprs $ map (hsExpr . fst) tds, flags = [ ("probs","probabilities from this file (format 'f 0.6' per line)") ], @@ -423,7 +399,7 @@ pgfCommands = Map.fromList [ mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result" ] }), - +{- ("tq", emptyCommandInfo { longname = "translation_quiz", syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?", @@ -572,17 +548,13 @@ pgfCommands = Map.fromList [ "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."--, --- "With option -mk, use for showing library style function names of form 'mkC'." + "flag -format." ], exec = needPGF $ \opts arg env@(pgf, _) -> let es = toExprs arg in - {-if isOpt "mk" opts - then return $ fromString $ unlines $ map (tree2mk pgf) es - else -}if isOpt "api" opts + if isOpt "api" opts then do - let ss = map exprToAPI es - mapM_ putStrLn ss + mapM_ (putStrLn . exprToAPI) es return void else do let gvOptions=graphvizDefaults{noFun = isOpt "nofun" opts, @@ -607,7 +579,6 @@ pgfCommands = Map.fromList [ ], options = [ ("api", "show the tree with function names converted to 'mkC' with value cats C"), --- ("mk", "similar to -api, deprecated"), ("nofun","don't show functions but only categories"), ("nocat","don't show categories but only functions") ], @@ -635,23 +606,22 @@ pgfCommands = Map.fromList [ exec = needPGF $ \opts args env@(pgf,cncs) -> case map cExpr (toExprs args) of [e] -> case unApp e of - Just (id,[]) | id `elem` funs -> return (fromString (showFun pgf id)) - | id `elem` cats -> return (fromString (showCat id)) - where - funs = functions pgf - cats = categories pgf - - showCat c = "cat "++c -- TODO: show categoryContext - ++"\n\n"++ - unlines [showFun' f ty|f<-funs, - let ty=functionType pgf f, - target ty == c] - target t = case unType t of (_,c,_) -> c + 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 "++showCategory pgf 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 (H.probTree pgf e)) + putStrLn ("Probability: "++show (treeProbability pgf e)) return void _ -> do putStrLn "a single function name or category name is expected" return void, @@ -759,8 +729,7 @@ pgfCommands = Map.fromList [ 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 . unlines . map (showFun pgf) $ - functions 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 @@ -768,11 +737,14 @@ pgfCommands = Map.fromList [ | isOpt "lexc" opts = return $ fromString $ concatMap (prLexcLexicon . snd) $ optConcs env opts | otherwise = return void - showFun pgf f = showFun' f (functionType pgf f) - showFun' f ty = "fun "++f++" : "++showType [] ty + 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,lookupMorpho concr s) | (lang,concr) <- optConcs env opts] + [(s,res) | (lang,concr) <- optConcs env opts, let res = lookupMorpho concr s, not (null res)] {- mexp xs = case xs of t:_ -> Just t |