diff options
Diffstat (limited to 'src-2.9/GF/API.hs')
| -rw-r--r-- | src-2.9/GF/API.hs | 472 |
1 files changed, 0 insertions, 472 deletions
diff --git a/src-2.9/GF/API.hs b/src-2.9/GF/API.hs deleted file mode 100644 index b1deeddfc..000000000 --- a/src-2.9/GF/API.hs +++ /dev/null @@ -1,472 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : API --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:40 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.39 $ --- --- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001 ------------------------------------------------------------------------------ - -module GF.API where - -import qualified GF.Source.AbsGF as GF -import qualified GF.Canon.AbsGFC as A -import qualified GF.Compile.Rename as R -import GF.UseGrammar.GetTree -import GF.Canon.GFC ---- import qualified Values as V -import GF.Grammar.Values - ------import GetGrammar -import GF.Compile.Compile -import GF.API.IOGrammar -import GF.UseGrammar.Linear -import GF.UseGrammar.Parsing -import GF.UseGrammar.Morphology -import GF.CF.PPrCF -import GF.CF.CFIdent -import GF.Compile.PGrammar -import GF.UseGrammar.Randomized (mkRandomTree) - -import GF.Grammar.MMacros -import qualified GF.Grammar.Macros as M -import GF.Grammar.TypeCheck -import GF.Canon.CMacros -import GF.UseGrammar.Transfer -import qualified GF.UseGrammar.Generate as Gen - -import GF.Text.Text (untokWithXML) -import GF.Infra.Option -import GF.UseGrammar.Custom -import GF.Compile.ShellState -import GF.UseGrammar.Linear -import GF.Canon.GFC -import qualified GF.Grammar.Grammar as G -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import qualified GF.Grammar.Compute as Co -import qualified GF.Grammar.AbsCompute as AC -import qualified GF.Infra.Ident as I -import qualified GF.Compile.GrammarToCanon as GC -import qualified GF.Canon.CanonToGrammar as CG -import qualified GF.Canon.MkGFC as MC -import qualified GF.Embed.EmbedAPI as EA - -import GF.UseGrammar.Editing - -import GF.System.SpeechInput (recognizeSpeech) - -----import GrammarToXML - -----import GrammarToMGrammar as M - -import qualified Transfer.InterpreterAPI as T - -import GF.System.Arch (myStdGen) - -import GF.Text.UTF8 -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Data.Zipper - -import Data.List (nub) -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Control.Monad (liftM) -import System (system) -import System.FilePath - -type GFGrammar = StateGrammar -type GFCat = CFCat -type Ident = I.Ident ---- type Tree = V.Tree - --- these are enough for many simple applications - -file2grammar :: FilePath -> IO GFGrammar -file2grammar file = do - egr <- appIOE $ optFile2grammar (iOpts [beSilent]) file - err (\s -> putStrLn s >> return emptyStateGrammar) return egr - -linearize :: GFGrammar -> Tree -> String -linearize sgr = err id id . optLinearizeTree opts sgr where - opts = addOption firstLin $ stateOptions sgr - -term2tree :: GFGrammar -> G.Term -> Tree -term2tree gr = errVal uTree . annotate (grammar gr) . qualifTerm (absId gr) - -tree2term :: Tree -> G.Term -tree2term = tree2exp - -linearizeToAll :: [GFGrammar] -> Tree -> [String] -linearizeToAll grs t = [linearize gr t | gr <- grs] - -parse :: GFGrammar -> GFCat -> String -> [Tree] -parse sgr cat = errVal [] . parseString noOptions sgr cat - -parseAny :: [GFGrammar] -> GFCat -> String -> [Tree] -parseAny grs cat s = - concat [errVal [] (parseString (options [iOpt "trynextlang"]) gr cat s) | gr <- grs] - -translate :: GFGrammar -> GFGrammar -> GFCat -> String -> [String] -translate ig og cat = map (linearize og) . parse ig cat - -translateToAll :: GFGrammar -> [GFGrammar] -> GFCat -> String -> [String] -translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat - -translateFromAny :: [GFGrammar] -> GFGrammar -> GFCat -> String -> [String] -translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs] - -translateBetweenAll :: [GFGrammar] -> GFCat -> String -> [String] -translateBetweenAll grs cat = - concat . map (linearizeToAll grs) . parseAny grs cat - -homonyms :: GFGrammar -> GFCat -> Tree -> [Tree] -homonyms gr cat = nub . parse gr cat . linearize gr - -hasAmbiguousLin :: GFGrammar -> GFCat -> Tree -> Bool -hasAmbiguousLin gr cat t = case (homonyms gr cat t) of - _:_:_ -> True - _ -> False - -{- ---- --- returns printname if one exists; othewrise linearizes with metas -printOrLin :: GFGrammar -> Fun -> String -printOrLin gr = printOrLinearize (stateGrammarST gr) - --- reads a syntax file and writes it in a format wanted -transformGrammarFile :: Options -> FilePath -> IO String -transformGrammarFile opts file = do - sy <- useIOE GF.emptySyntax $ getSyntax opts file - return $ optPrintSyntax opts sy --} - -prIdent :: Ident -> String -prIdent = prt - -string2GFCat :: String -> String -> GFCat -string2GFCat = string2CFCat - --- then stg for customizable and internal use - -optFile2grammar :: Options -> FilePath -> IOE GFGrammar -optFile2grammar os f - | takeExtensions f == ".gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f - | otherwise = do - ((_,_,gr,_),_) <- compileModule os emptyShellState f - ioeErr $ grammar2stateGrammar os gr - -optFile2grammarE :: Options -> FilePath -> IOE GFGrammar -optFile2grammarE = optFile2grammar - - -string2treeInState :: GFGrammar -> String -> State -> Err Tree -string2treeInState gr s st = do - let metas = allMetas st - xs = map fst $ actBinds st - t0 <- pTerm s - let t = qualifTerm (absId gr) $ M.mkAbs xs $ refreshMetas metas $ t0 - annotateExpInState (grammar gr) t st - -string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term -string2srcTerm gr m s = do - t <- pTerm s - R.renameSourceTerm gr m t - -randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree] -randomTreesIO opts gr n = do - gen <- myStdGen mx - t <- err (\s -> putS s >> return []) - (return . singleton) $ - mkRandomTree gen mx g catfun - ts <- if n==1 then return [] else randomTreesIO opts gr (n-1) - return $ t ++ ts - where - catfun = case getOptVal opts withFun of - Just fun -> Right $ (absId gr, I.identC fun) - _ -> Left $ firstAbsCat opts gr - g = grammar gr - mx = optIntOrN opts flagDepth 41 - putS s = if oElem beSilent opts then return () else putStrLnFlush s - - -generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree] -generateTrees opts gr mt = - optIntOrAll opts flagNumber - [tr | t <- Gen.generateTrees opts gr' cat dpt mn mt, Ok tr <- [mkTr t]] - where - mkTr = annotate gr' . qualifTerm (absId gr) - gr' = grammar gr - cat = firstAbsCat opts gr - dpt = maybe 3 id $ getOptInt opts flagDepth - mn = getOptInt opts flagAlts - -speechGenerate :: Options -> String -> IO () -speechGenerate opts str = do - let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage - system ("flite" +++ "\" " ++ str ++ "\"") ---- system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan) - return () - -speechInput :: Options -> StateGrammar -> IO [String] -speechInput opt s = recognizeSpeech name language cfg cat number - where - opts = addOptions opt (stateOptions s) - name = cncId s - cfg = stateCFG s -- FIXME: use lang flag to select grammar - language = fromMaybe "en_UK" (getOptVal opts speechLanguage) - cat = prCFCat (firstCatOpts opts s) ++ "{}.s" - number = optIntOrN opts flagNumber 1 - -optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String -optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr - -optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String -optLinearizeTree opts0 gr t = case getOptVal opts transferFun of - Just m -> useByTransfer flin g (I.identC m) t - _ -> flin t - where - opts = addOptions opts0 (stateOptions gr) - flin = case getOptVal opts markLin of - Just mk - | mk == markOptXML -> lin markXML - | mk == markOptJava -> lin markXMLjgf - | mk == markOptStruct -> lin markBracket - | mk == markOptFocus -> lin markFocus - | mk == "metacat" -> lin metaCatMark - | otherwise -> lin noMark - _ -> lin noMark - - lin mk - | oElem showRecord opts = liftM prt . linearizeNoMark g c - | oElem tableLin opts = liftM (unlines . map untok . prLinTable True) . - allLinTables True g c - | oElem showFields opts = liftM (unlines . map untok) . - allLinBranchFields g c - | oElem showAll opts = liftM (unlines . map untok . prLinTable False) . - allLinTables False g c - | otherwise = return . unlines . map untok . optIntOrOne . linTree2strings mk g c - g = grammar gr - c = cncId gr - untok = if False ---- oElem (markLin markOptXML) opts - then untokWithXML unt - else unt - unt = customOrDefault opts useUntokenizer customUntokenizer gr - optIntOrOne = take $ optIntOrN opts flagNumber 1 - -{- ---- - untoksl . lin where - gr = concreteOf (stateGrammarST sgr) - lin -- options mutually exclusive, with priority: struct, rec, table, one - | oElem showStruct opts = markedLinString True gr . tree2loc - | oElem showRecord opts = err id prt . linTerm gr - | oElem tableLin opts = err id (concatMap prLinTable) . allLinsAsStrs gr - | oElem firstLin opts = unlines . map sstr . take 1 . allLinStrings gr - | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr - untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr - opts' = addOptions opts $ stateOptions sgr - untoksl = unlines . map untoks . lines --} - -{- -optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String -optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where - gr = concreteOf (stateGrammarST sgr) - ts = annotateTrm sgr ts0 - ms = map (renameTrm (lookupConcrete gr)) fs - lin -- options mutually exclusive, with priority: struct, rec, table - | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms - | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms - tkStrs = concat . map snd . concat . map snd - untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr - opts' = addOptions opts $ stateOptions sgr - untoksl = unlines . map untoks . lines --} - -optParseArg :: Options -> GFGrammar -> String -> [Tree] -optParseArg opts gr = err (const []) id . optParseArgErr opts gr - -optParseArgAny :: Options -> [GFGrammar] -> String -> [Tree] -optParseArgAny opts grs s = concat [pars gr s | gr <- grs] where - pars gr = optParseArg opts gr --- grammar options! - -optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree] -optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr - -optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String) -optParseArgErrMsg opts gr s = do - let cat = firstCatOpts opts gr - g = grammar gr - (ts,m) <- parseStringMsg opts gr cat s - ts' <- case getOptVal opts transferFun of - Just m -> mkByTransfer (const $ return ts) g (I.identC m) s - _ -> return ts - return (ts',m) - --- | analyses word by word -morphoAnalyse :: Options -> GFGrammar -> String -> String -morphoAnalyse opts gr - | oElem (iOpt "status") opts = morphoTextStatus mo - | oElem beShort opts = morphoTextShort mo - | otherwise = morphoText mo - where - mo = morpho gr - -isKnownWord :: GFGrammar -> String -> Bool -isKnownWord gr s = GF.UseGrammar.Morphology.isKnownWord (morpho gr) s - -unknownTokens :: GFGrammar -> [CFTok] -> [String] -unknownTokens gr ts = - [w | TC w <- ts, unk w && unk (uncap w)] ++ [w | TS w <- ts, unk w] - where - unk w = not $ GF.API.isKnownWord gr w - uncap (c:cs) = toLower c : cs - uncap s = s - - -{- -prExpXML :: StateGrammar -> Term -> [String] -prExpXML gr = prElementX . term2elemx (stateAbstract gr) - -prMultiGrammar :: Options -> ShellState -> String -prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts) --} --- access to customizable commands - -optPrintGrammar :: Options -> StateGrammar -> String -optPrintGrammar opts = pg opts - where - pg = customOrDefault opts grammarPrinter customGrammarPrinter - -optPrintMultiGrammar :: Options -> CanonGrammar -> String -optPrintMultiGrammar opts = encodeId . pmg opts . encode - where - pmg = customOrDefault opts grammarPrinter customMultiGrammarPrinter - -- if -utf8 was given, convert from language specific codings - encode = if oElem useUTF8 opts then mapModules moduleToUTF8 else id - -- if -utf8id was given, convert non-literals to UTF8 - encodeId = if oElem useUTF8id opts then nonLiteralsToUTF8 else id - moduleToUTF8 m = - m{ jments = mapTree (onSnd (mapInfoTerms code)) (jments m), - flags = setFlag "coding" "utf8" (flags m) } - where code = onTokens (anyCodingToUTF8 (moduleOpts m)) - moduleOpts = Opts . okError . mapM CG.redFlag . flags - -optPrintSyntax :: Options -> GF.Grammar -> String -optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter - -optPrintTree :: Options -> GFGrammar -> Tree -> String -optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter - --- | look for string command (-filter=x) -optStringCommand :: Options -> GFGrammar -> String -> String -optStringCommand opts g = - optIntOrAll opts flagLength . - customOrDefault opts filterString customStringCommand g - -optTermCommand :: Options -> GFGrammar -> Tree -> [Tree] -optTermCommand opts st = - optIntOrAll opts flagNumber . - customOrDefault opts termCommand customTermCommand st - - --- wraps term in a function and optionally computes the result - -wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree -wrapByFun opts gr f t = - if oElem doCompute opts - then err (const t) id $ AC.computeAbsTerm (grammar gr) t' >>= annotate g - else err (const t) id $ annotate g t' - where - t' = qualifTerm (absId gr) $ M.appCons f [tree2exp t] - g = grammar gr - -applyTransfer :: Options -> GFGrammar -> [(Ident,T.Env)] -> - (Maybe Ident,Ident) -> Tree -> Err [Tree] -applyTransfer opts gr trs (mm,f) t = mapM (annotate g) ts' - where - ts' = map (qualifTerm (absId gr)) $ trans tr f $ tree2exp t - g = grammar gr - tr = case mm of - Just m -> maybe empty id $ lookup m trs - _ -> ifNull empty (snd . head) trs - -- FIXME: if the returned value is a list, - -- return a list of trees - trans :: T.Env -> Ident -> Exp -> [Exp] - trans tr f = (:[]) . core2exp . T.evaluateExp tr . exp2core f - empty = T.builtin - -{- -optTransfer :: Options -> StateGrammar -> G.Term -> G.Term -optTransfer opts g = case getOptVal opts transferFun of - Just f -> wrapByFun (addOption doCompute opts) g (M.zIdent f) - _ -> id --} - -optTokenizerResult :: Options -> GFGrammar -> String -> [[CFTok]] -optTokenizerResult opts gr = customOrDefault opts useTokenizer customTokenizer gr - -optTokenizer :: Options -> GFGrammar -> String -> String -optTokenizer opts gr = show . optTokenizerResult opts gr - --- performs UTF8 if the language does not have flag coding=utf8; replaces name*U - --- | convert a Unicode string into a UTF8 encoded string -optEncodeUTF8 :: GFGrammar -> String -> String -optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of - Just "utf8" -> id - _ -> encodeUTF8 - --- | convert a UTF8 encoded string into a Unicode string -optDecodeUTF8 :: GFGrammar -> String -> String -optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of - Just "utf8" -> decodeUTF8 - _ -> id - --- | convert a string encoded with some coding given by the coding flag to UTF8 -anyCodingToUTF8 :: Options -> String -> String -anyCodingToUTF8 opts = - encodeUTF8 . customOrDefault opts uniCoding customUniCoding - - --- | Convert all text not inside double quotes to UTF8 -nonLiteralsToUTF8 :: String -> String -nonLiteralsToUTF8 "" = "" -nonLiteralsToUTF8 ('"':cs) = '"' : l ++ nonLiteralsToUTF8 rs - where - (l,rs) = takeStringLit cs - -- | Split off an initial string ended by double quotes - takeStringLit :: String -> (String,String) - takeStringLit "" = ("","") - takeStringLit ('"':cs) = (['"'],cs) - takeStringLit ('\\':'"':cs) = ('\\':'"':xs,ys) - where (xs,ys) = takeStringLit cs - takeStringLit (c:cs) = (c:xs,ys) - where (xs,ys) = takeStringLit cs -nonLiteralsToUTF8 (c:cs) = encodeUTF8 [c] ++ nonLiteralsToUTF8 cs - - -printParadigm :: G.Term -> String -printParadigm term = - if hasTable term then - (unlines . map prBranch . branches . head . tables) term - else - prt term - where - tables t = case t of - G.R rs -> concatMap (tables . snd . snd) rs - G.T _ cs -> [cs] - _ -> [] - hasTable t = not $ null $ tables t - branches cs = [(p:ps,s) | - (p,t) <- cs, - let ts = tables t, - (ps,s) <- if null ts then [([],t)] - else concatMap branches ts - ] - prBranch (ps,s) = unwords (map prt ps ++ [prt s]) |