summaryrefslogtreecommitdiff
path: root/src-3.0/GF/UseGrammar
diff options
context:
space:
mode:
authorkr.angelov <kr.angelov@chalmers.se>2008-05-22 11:59:31 +0000
committerkr.angelov <kr.angelov@chalmers.se>2008-05-22 11:59:31 +0000
commitdf0c4f81fa9c620d7c63af79c0b183a6beccf0bd (patch)
tree0cdc80b29f8f5df0ad280f17be0ba9d46fbd948c /src-3.0/GF/UseGrammar
parent6394f3ccfbb9d14017393b433a38a3921f1083e5 (diff)
remove all files that aren't used in GF-3.0
Diffstat (limited to 'src-3.0/GF/UseGrammar')
-rw-r--r--src-3.0/GF/UseGrammar/Custom.hs494
-rw-r--r--src-3.0/GF/UseGrammar/Editing.hs434
-rw-r--r--src-3.0/GF/UseGrammar/Generate.hs116
-rw-r--r--src-3.0/GF/UseGrammar/GetTree.hs74
-rw-r--r--src-3.0/GF/UseGrammar/Information.hs162
-rw-r--r--src-3.0/GF/UseGrammar/Linear.hs292
-rw-r--r--src-3.0/GF/UseGrammar/MatchTerm.hs50
-rw-r--r--src-3.0/GF/UseGrammar/Morphology.hs140
-rw-r--r--src-3.0/GF/UseGrammar/Paraphrases.hs70
-rw-r--r--src-3.0/GF/UseGrammar/Parsing.hs177
-rw-r--r--src-3.0/GF/UseGrammar/Randomized.hs66
-rw-r--r--src-3.0/GF/UseGrammar/Session.hs181
-rw-r--r--src-3.0/GF/UseGrammar/Statistics.hs44
-rw-r--r--src-3.0/GF/UseGrammar/Tokenize.hs222
-rw-r--r--src-3.0/GF/UseGrammar/Transfer.hs79
-rw-r--r--src-3.0/GF/UseGrammar/TreeSelections.hs77
-rw-r--r--src-3.0/GF/UseGrammar/Treebank.hs251
17 files changed, 0 insertions, 2929 deletions
diff --git a/src-3.0/GF/UseGrammar/Custom.hs b/src-3.0/GF/UseGrammar/Custom.hs
deleted file mode 100644
index 983b7f683..000000000
--- a/src-3.0/GF/UseGrammar/Custom.hs
+++ /dev/null
@@ -1,494 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Custom
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/16 10:21:21 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.85 $
---
--- A database for customizable GF shell commands.
---
--- databases for customizable commands. AR 21\/11\/2001.
--- for: grammar parsers, grammar printers, term commands, string commands.
--- idea: items added here are usable throughout GF; nothing else need be edited.
--- they are often usable through the API: hence API cannot be imported here!
---
--- Major redesign 3\/4\/2002: the first entry in each database is DEFAULT.
--- If no other value is given, the default is selected.
--- Because of this, two invariants have to be preserved:
---
--- - no databases may be empty
---
--- - additions are made to the end of the database
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Custom where
-
-import GF.Data.Operations
-import GF.Text.Text
-import GF.UseGrammar.Tokenize
-import GF.Grammar.Values
-import qualified GF.Grammar.Grammar as G
-import qualified GF.Canon.AbsGFC as A
-import qualified GF.Canon.GFC as C
-
-import qualified GF.Devel.GFCCtoJS as JS
-import GF.Canon.CanonToGFCC
-import qualified GF.Devel.GFCCtoHaskell as CCH
-
-import qualified GF.Source.AbsGF as GF
-import qualified GF.Grammar.MMacros as MM
-import GF.Grammar.AbsCompute
-import GF.Grammar.TypeCheck
-import GF.UseGrammar.Generate
-import GF.UseGrammar.MatchTerm
-import GF.UseGrammar.Linear (unoptimizeCanon)
-------import Compile
-import GF.Compile.ShellState
-import GF.UseGrammar.Editing
-import GF.UseGrammar.Paraphrases
-import GF.Infra.Option
-import GF.CF.CF
-import GF.CF.CFIdent
-
-import GF.Canon.CanonToGrammar
-import GF.CF.PPrCF
-import GF.CF.PrLBNF
-import GF.Grammar.PrGrammar
-import GF.Compile.PrOld
-import GF.Canon.MkGFC
-import GF.Speech.PrGSL (gslPrinter)
-import GF.Speech.PrJSGF (jsgfPrinter)
-import GF.Speech.PrSRGS
-import GF.Speech.PrSRGS_ABNF
-import qualified GF.Speech.SISR as SISR
-import GF.Speech.PrSLF
-import GF.Speech.PrFA (faGraphvizPrinter,regularPrinter,faCPrinter)
-import GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter)
-import GF.Speech.GrammarToVoiceXML (grammar2vxml)
-
-import GF.Data.Zipper
-
-import GF.UseGrammar.Statistics
-import GF.UseGrammar.Morphology
-import GF.UseGrammar.Information
-import GF.API.GrammarToHaskell
-import GF.API.GrammarToTransfer
------import GrammarToCanon (showCanon, showCanonOpt)
------import qualified GrammarToGFC as GFC
-import GF.Probabilistic.Probabilistic (prProbs)
-
--- the cf parsing algorithms
-import GF.CF.ChartParser -- OBSOLETE
-import qualified GF.Parsing.CF as PCF
-import qualified GF.OldParsing.ParseCF as PCFOld -- OBSOLETE
-
--- grammar conversions -- peb 19/4-04
--- see also customGrammarPrinter
-import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
-import qualified GF.Printing.PrintParser as PrtOld -- OBSOLETE
-import qualified GF.Infra.Print as Prt
-import qualified GF.Conversion.GFC as Cnv
-import qualified GF.Conversion.Types as CnvTypes
-import qualified GF.Conversion.Haskell as CnvHaskell
-import qualified GF.Conversion.Prolog as CnvProlog
-import qualified GF.Conversion.TypeGraph as CnvTypeGraph
-import GF.Canon.Unparametrize
-import GF.Canon.Subexpressions
-import GF.Canon.AbsToBNF
-
-import GF.Canon.GFC
-import qualified GF.Canon.MkGFC as MC
-import GF.CFGM.PrintCFGrammar (prCanonAsCFGM)
-import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSourceGrammar)
-
-import GF.API.MyParser
-
-import qualified GF.Infra.Modules as M
-import GF.Infra.UseIO
-
-import Control.Monad
-import Data.Char
-import Data.Maybe (fromMaybe)
-
--- character codings
-import GF.Text.Unicode
-import GF.Text.UTF8 (decodeUTF8)
-import GF.Text.Greek (mkGreek)
-import GF.Text.Arabic (mkArabic)
-import GF.Text.Hebrew (mkHebrew)
-import GF.Text.Russian (mkRussian, mkRusKOI8)
-import GF.Text.Ethiopic (mkEthiopic)
-import GF.Text.Tamil (mkTamil)
-import GF.Text.OCSCyrillic (mkOCSCyrillic)
-import GF.Text.LatinASupplement (mkLatinASupplement)
-import GF.Text.Devanagari (mkDevanagari)
-import GF.Text.Hiragana (mkJapanese)
-import GF.Text.ExtendedArabic (mkArabic0600)
-import GF.Text.ExtendedArabic (mkExtendedArabic)
-import GF.Text.ExtraDiacritics (mkExtraDiacritics)
-
--- minimal version also used in Hugs. AR 2/12/2002.
-
--- databases for customizable commands. AR 21/11/2001
--- for: grammar parsers, grammar printers, term commands, string commands
--- idea: items added here are usable throughout GF; nothing else need be edited
--- they are often usable through the API: hence API cannot be imported here!
-
--- Major redesign 3/4/2002: the first entry in each database is DEFAULT.
--- If no other value is given, the default is selected.
--- Because of this, two invariants have to be preserved:
--- - no databases may be empty
--- - additions are made to the end of the database
-
--- * these are the databases; the comment gives the name of the flag
-
--- | grammarFormat, \"-format=x\" or file suffix
-customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar)
-
--- | grammarPrinter, \"-printer=x\"
-customGrammarPrinter :: CustomData (Options -> StateGrammar -> String)
-
--- | multiGrammarPrinter, \"-printer=x\"
-customMultiGrammarPrinter :: CustomData (Options -> CanonGrammar -> String)
-
--- | syntaxPrinter, \"-printer=x\"
-customSyntaxPrinter :: CustomData (GF.Grammar -> String)
-
--- | termPrinter, \"-printer=x\"
-customTermPrinter :: CustomData (StateGrammar -> Tree -> String)
-
--- | termCommand, \"-transform=x\"
-customTermCommand :: CustomData (StateGrammar -> Tree -> [Tree])
-
--- | editCommand, \"-edit=x\"
-customEditCommand :: CustomData (StateGrammar -> Action)
-
--- | filterString, \"-filter=x\"
-customStringCommand :: CustomData (StateGrammar -> String -> String)
-
--- | useParser, \"-parser=x\"
-customParser :: CustomData (StateGrammar -> CFCat -> CFParser)
-
--- | useTokenizer, \"-lexer=x\"
-customTokenizer :: CustomData (StateGrammar -> String -> [[CFTok]])
-
--- | useUntokenizer, \"-unlexer=x\" --- should be from token list to string
-customUntokenizer :: CustomData (StateGrammar -> String -> String)
-
--- | uniCoding, \"-coding=x\"
---
--- contains conversions from different codings to the internal
--- unicode coding
-customUniCoding :: CustomData (String -> String)
-
--- | this is the way of selecting an item
-customOrDefault :: Options -> OptFun -> CustomData a -> a
-customOrDefault opts optfun db = maybe (defaultCustomVal db) id $
- customAsOptVal opts optfun db
-
--- | to produce menus of custom operations
-customInfo :: CustomData a -> (String, [String])
-customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c))
-
--------------------------------
--- * types and stuff
-
-type CommandId = String
-
-strCI :: String -> CommandId
-strCI = id
-
-ciStr :: CommandId -> String
-ciStr = id
-
-ciOpt :: CommandId -> Option
-ciOpt = iOpt
-
-newtype CustomData a = CustomData (String, [(CommandId,a)])
-
-customData :: String -> [(CommandId, a)] -> CustomData a
-customData title db = CustomData (title,db)
-
-dbCustomData :: CustomData a -> [(CommandId, a)]
-dbCustomData (CustomData (_,db)) = db
-
-titleCustomData :: CustomData a -> String
-titleCustomData (CustomData (t,_)) = t
-
-lookupCustom :: CustomData a -> CommandId -> Maybe a
-lookupCustom = flip lookup . dbCustomData
-
-customAsOptVal :: Options -> OptFun -> CustomData a -> Maybe a
-customAsOptVal opts optfun db = do
- arg <- getOptVal opts optfun
- lookupCustom db (strCI arg)
-
--- | take the first entry from the database
-defaultCustomVal :: CustomData a -> a
-defaultCustomVal (CustomData (s,db)) =
- ifNull (error ("empty database:" +++ s)) (snd . head) db
-
--------------------------------------------------------------------------
--- * and here's the customizable part:
-
--- grammar parsers: the ID is also used as file name suffix
-customGrammarParser =
- customData "Grammar parsers, selected by file name suffix" $
- [
------- (strCI "gf", compileModule noOptions) -- DEFAULT
--- add your own grammar parsers here
- ]
-
-
-customGrammarPrinter =
- customData "Grammar printers, selected by option -printer=x" $
- [
- (strCI "gfc", \_ -> prCanon . stateGrammarST) -- DEFAULT
- ,(strCI "gf", \_ -> err id prGrammar . canon2sourceGrammar . stateGrammarST)
- ,(strCI "cf", \_ -> prCF . stateCF)
- ,(strCI "old", \_ -> printGrammarOld . stateGrammarST)
- ,(strCI "gsl", gslPrinter)
- ,(strCI "jsgf", jsgfPrinter Nothing)
- ,(strCI "jsgf_sisr_old", jsgfPrinter (Just SISR.SISROld))
- ,(strCI "srgs_xml", srgsXmlPrinter Nothing False)
- ,(strCI "srgs_xml_non_rec", srgsXmlNonRecursivePrinter)
- ,(strCI "srgs_xml_prob", srgsXmlPrinter Nothing True)
- ,(strCI "srgs_xml_sisr_old", srgsXmlPrinter (Just SISR.SISROld) False)
- ,(strCI "srgs_abnf", srgsAbnfPrinter Nothing False)
- ,(strCI "srgs_abnf_non_rec", srgsAbnfNonRecursivePrinter)
- ,(strCI "srgs_abnf_sisr_old", srgsAbnfPrinter (Just SISR.SISROld) False)
- ,(strCI "vxml", grammar2vxml)
- ,(strCI "slf", slfPrinter)
- ,(strCI "slf_graphviz", slfGraphvizPrinter)
- ,(strCI "slf_sub", slfSubPrinter)
- ,(strCI "slf_sub_graphviz", slfSubGraphvizPrinter)
- ,(strCI "fa_graphviz", faGraphvizPrinter)
- ,(strCI "fa_c", faCPrinter)
- ,(strCI "regexp", regexpPrinter)
- ,(strCI "regexps", multiRegexpPrinter)
- ,(strCI "regular", regularPrinter)
- ,(strCI "plbnf", \_ -> prLBNF True)
- ,(strCI "lbnf", \_ -> prLBNF False)
- ,(strCI "bnf", \_ -> prBNF False)
- ,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST)
- ,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST)
- ,(strCI "gfcc_haskell", \opts -> CCH.grammar2haskell .
- canon2gfcc opts . stateGrammarST)
- ,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST)
- ,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)
- ,(strCI "morpho", \_ -> prMorpho . stateMorpho)
- ,(strCI "fullform",\_ -> prFullForm . stateMorpho)
- ,(strCI "opts", \_ -> prOpts . stateOptions)
- ,(strCI "words", \_ -> unwords . stateGrammarWords)
- ,(strCI "printnames", \_ -> C.prPrintnamesGrammar . stateGrammarST)
- ,(strCI "stat", \_ -> prStatistics . stateGrammarST)
- ,(strCI "probs", \_ -> prProbs . stateProbs)
- ,(strCI "unpar", \_ -> prCanon . unparametrizeCanon . stateGrammarST)
- ,(strCI "subs", \_ -> prSubtermStat . stateGrammarST)
-
-{- ----
- (strCI "gf", prt . st2grammar . stateGrammarST) -- DEFAULT
- ,(strCI "canon", showCanon "Lang" . stateGrammarST)
- ,(strCI "gfc", GFC.showGFC . stateGrammarST)
- ,(strCI "canonOpt",showCanonOpt "Lang" . stateGrammarST)
--}
-
--- add your own grammar printers here
-
--- grammar conversions:
- ,(strCI "mcfg", \_ -> Prt.prt . stateMCFG)
- ,(strCI "fcfg", \_ -> Prt.prt . fst . stateFCFG)
- ,(strCI "cfg", \_ -> Prt.prt . stateCFG)
- ,(strCI "pinfo", \_ -> Prt.prt . statePInfo)
- ,(strCI "abstract", \_ -> Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang)
-
- ,(strCI "functiongraph",\_ -> CnvTypeGraph.prtFunctionGraph . Cnv.gfc2simple noOptions . stateGrammarLang)
- ,(strCI "typegraph", \_ -> CnvTypeGraph.prtTypeGraph . Cnv.gfc2simple noOptions . stateGrammarLang)
-
- ,(strCI "gfc-haskell", \_ -> CnvHaskell.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
- ,(strCI "mcfg-haskell", \_ -> CnvHaskell.prtMGrammar . stateMCFG)
- ,(strCI "cfg-haskell", \_ -> CnvHaskell.prtCGrammar . stateCFG)
- ,(strCI "gfc-prolog", \_ -> CnvProlog.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
- ,(strCI "mcfg-prolog", \_ -> CnvProlog.prtMGrammar . stateMCFG)
- ,(strCI "cfg-prolog", \_ -> CnvProlog.prtCGrammar . stateCFG)
-
--- obsolete, or only for testing:
- ,(strCI "abs-skvatt", \_ -> Cnv.abstract2skvatt . Cnv.gfc2abstract . stateGrammarLang)
- ,(strCI "cfg-skvatt", \_ -> Cnv.cfg2skvatt . stateCFG)
- ,(strCI "simple", \_ -> Prt.prt . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
- ,(strCI "mcfg-erasing", \_ -> Prt.prt . fst . snd . uncurry Cnv.convertGFC . stateGrammarLangOpts)
--- ,(strCI "mcfg-old", PrtOld.prt . CnvOld.mcfg . statePInfoOld)
--- ,(strCI "cfg-old", PrtOld.prt . CnvOld.cfg . statePInfoOld)
- ]
- where stateGrammarLangOpts s = (stateOptions s, stateGrammarLang s)
-
-customMultiGrammarPrinter =
- customData "Printers for multiple grammars, selected by option -printer=x" $
- [
- (strCI "gfcm", const MC.prCanon)
- ,(strCI "gfcc", canon2gfccPr)
- ,(strCI "js", \opts -> JS.gfcc2js . canon2gfcc opts)
- ,(strCI "header", const (MC.prCanonMGr . unoptimizeCanon))
- ,(strCI "cfgm", prCanonAsCFGM)
- ,(strCI "graph", visualizeCanonGrammar)
- ,(strCI "missing", const missingLinCanonGrammar)
-
--- to prolog format:
- ,(strCI "gfc-prolog", CnvProlog.prtSMulti)
- ,(strCI "mcfg-prolog", CnvProlog.prtMMulti)
- ,(strCI "cfg-prolog", CnvProlog.prtCMulti)
- ]
-
-
-customSyntaxPrinter =
- customData "Syntax printers, selected by option -printer=x" $
- [
--- add your own grammar printers here
- ]
-
-
-customTermPrinter =
- customData "Term printers, selected by option -printer=x" $
- [
- (strCI "gf", const prt) -- DEFAULT
--- add your own term printers here
- ]
-
-customTermCommand =
- customData "Term transformers, selected by option -transform=x" $
- [
- (strCI "identity", \_ t -> [t]) -- DEFAULT
- ,(strCI "compute", \g t -> let gr = grammar g in
- err (const [t]) return
- (exp2termCommand gr (computeAbsTerm gr) t))
- ,(strCI "nodup", \_ t -> if (hasDupIdent $ tree2exp t) then [] else [t])
- ,(strCI "nodupatom", \_ t -> if (hasDupAtom $ tree2exp t) then [] else [t])
- ,(strCI "paraphrase", \g t -> let gr = grammar g in
- exp2termlistCommand gr (mkParaphrases gr) t)
-
- ,(strCI "generate", \g t -> let gr = grammar g
- cat = actCat $ tree2loc t --- not needed
- in
- [tr | t <- generateTrees noOptions gr cat 2 Nothing (Just t),
- Ok tr <- [annotate gr $ MM.qualifTerm (absId g) t]])
- ,(strCI "typecheck", \g t -> err (const []) (return . loc2tree)
- (reCheckStateReject (grammar g) (tree2loc t)))
- ,(strCI "solve", \g t -> err (const []) (return . loc2tree)
- (solveAll (grammar g) (tree2loc t)
- >>= rejectUnsolvable))
- ,(strCI "context", \g t -> err (const [t]) (return . loc2tree)
- (contextRefinements (grammar g) (tree2loc t)))
- ,(strCI "reindex", \g t -> let gr = grammar g in
- err (const [t]) return
- (exp2termCommand gr (return . MM.reindexTerm) t))
---- ,(strCI "delete", \g t -> [MM.mExp0])
--- add your own term commands here
- ]
-
-customEditCommand =
- customData "Editor state transformers, selected by option -edit=x" $
- [
- (strCI "identity", const return) -- DEFAULT
- ,(strCI "typecheck", \g -> reCheckState (grammar g))
- ,(strCI "solve", \g -> solveAll (grammar g))
- ,(strCI "context", \g -> contextRefinements (grammar g))
- ,(strCI "compute", \g -> computeSubTree (grammar g))
- ,(strCI "paraphrase", const return) --- done ad hoc on top level
- ,(strCI "generate", const return) --- done ad hoc on top level
- ,(strCI "transfer", const return) --- done ad hoc on top level
--- add your own edit commands here
- ]
-
-customStringCommand =
- customData "String filters, selected by option -filter=x" $
- [
- (strCI "identity", const $ id) -- DEFAULT
- ,(strCI "erase", const $ const "")
- ,(strCI "take100", const $ take 100)
- ,(strCI "text", const $ formatAsText)
- ,(strCI "code", const $ formatAsCode)
----- ,(strCI "latexfile", const $ mkLatexFile)
- ,(strCI "length", const $ show . length)
--- add your own string commands here
- ]
-
-customParser =
- customData "Parsers, selected by option -parser=x" $
- [
- (strCI "chart", PCFOld.parse "ibn" . stateCF) -- DEPRECATED
- ,(strCI "bottomup", PCF.parse "gb" . stateCF)
- ,(strCI "topdown", PCF.parse "gt" . stateCF)
--- commented for now, since there's a bug in the incremental algorithm:
--- ,(strCI "incremental", PCF.parse "ib" . stateCF)
--- ,(strCI "incremental-bottomup", PCF.parse "ib" . stateCF)
--- ,(strCI "incremental-topdown", PCF.parse "it" . stateCF)
- ,(strCI "old", chartParser . stateCF) -- DEPRECATED
- ,(strCI "myparser", myParser)
--- add your own parsers here
- ]
-
-customTokenizer =
- let sg = singleton in
- customData "Tokenizers, selected by option -lexer=x" $
- [
- (strCI "words", const $ sg . tokWords)
- ,(strCI "literals", const $ sg . tokLits)
- ,(strCI "vars", const $ sg . tokVars)
- ,(strCI "chars", const $ sg . map (tS . singleton))
- ,(strCI "code", const $ sg . lexHaskell)
- ,(strCI "codevars", \gr -> sg . (lexHaskellVar $ stateIsWord gr))
- ,(strCI "textvars", \gr -> sg . (lexTextVar $ stateIsWord gr))
- ,(strCI "text", const $ sg . lexText)
- ,(strCI "unglue", \gr -> sg . map tS . decomposeWords (stateMorpho gr))
- ,(strCI "codelit", \gr -> sg . (lexHaskellLiteral $ stateIsWord gr))
- ,(strCI "textlit", \gr -> sg . (lexTextLiteral $ stateIsWord gr))
- ,(strCI "codeC", const $ sg . lexC2M)
- ,(strCI "ignore", \gr -> sg . lexIgnore (stateIsWord gr) . tokLits)
- ,(strCI "subseqs", \gr -> subSequences . lexIgnore (stateIsWord gr) . tokLits)
- ,(strCI "codeCHigh", const $ sg . lexC2M' True)
--- add your own tokenizers here
- ]
-
-customUntokenizer =
- customData "Untokenizers, selected by option -unlexer=x" $
- [
- (strCI "unwords", const $ id) -- DEFAULT
- ,(strCI "text", const $ formatAsText)
- ,(strCI "html", const $ formatAsHTML)
- ,(strCI "latex", const $ formatAsLatex)
- ,(strCI "code", const $ formatAsCode)
- ,(strCI "concat", const $ filter (not . isSpace))
- ,(strCI "textlit", const $ formatAsTextLit)
- ,(strCI "codelit", const $ formatAsCodeLit)
- ,(strCI "concat", const $ concatRemSpace)
- ,(strCI "glue", const $ performBinds)
- ,(strCI "finnish", const $ performBindsFinnish)
- ,(strCI "reverse", const $ reverse)
- ,(strCI "bind", const $ performBinds) -- backward compat
--- add your own untokenizers here
- ]
-
-customUniCoding =
- customData "Alphabet codings, selected by option -coding=x" $
- [
- (strCI "latin1", id) -- DEFAULT
- ,(strCI "utf8", decodeUTF8)
- ,(strCI "greek", treat [] mkGreek)
- ,(strCI "hebrew", mkHebrew)
- ,(strCI "arabic", mkArabic)
- ,(strCI "russian", treat [] mkRussian)
- ,(strCI "russianKOI8", mkRusKOI8)
- ,(strCI "ethiopic", mkEthiopic)
- ,(strCI "tamil", mkTamil)
- ,(strCI "OCScyrillic", mkOCSCyrillic)
- ,(strCI "devanagari", mkDevanagari)
- ,(strCI "latinasupplement", mkLatinASupplement)
- ,(strCI "japanese", mkJapanese)
- ,(strCI "arabic0600", mkArabic0600)
- ,(strCI "extendedarabic", mkExtendedArabic)
- ,(strCI "extradiacritics", mkExtraDiacritics)
- ]
diff --git a/src-3.0/GF/UseGrammar/Editing.hs b/src-3.0/GF/UseGrammar/Editing.hs
deleted file mode 100644
index 85fee1be4..000000000
--- a/src-3.0/GF/UseGrammar/Editing.hs
+++ /dev/null
@@ -1,434 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Editing
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:45 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.14 $
---
--- generic tree editing, with some grammar notions assumed. AR 18\/8\/2001.
--- 19\/6\/2003 for GFC
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Editing where
-
-import GF.Grammar.Abstract
-import qualified GF.Canon.GFC as GFC
-import GF.Grammar.TypeCheck
-import GF.Grammar.LookAbs
-import GF.Grammar.AbsCompute
-
-import GF.Data.Operations
-import GF.Data.Zipper
-
--- generic tree editing, with some grammar notions assumed. AR 18/8/2001
--- 19/6/2003 for GFC
-
-type CGrammar = GFC.CanonGrammar
-
-type State = Loc TrNode
-
--- | the "empty" state
-initState :: State
-initState = tree2loc uTree
-
-isRootState :: State -> Bool
-isRootState s = case actPath s of
- Top -> True
- _ -> False
-
-actTree :: State -> Tree
-actTree (Loc (t,_)) = t
-
-actPath :: State -> Path TrNode
-actPath (Loc (_,p)) = p
-
-actVal :: State -> Val
-actVal = valNode . nodeTree . actTree
-
-actCat :: State -> Cat
-actCat = errVal (cMeta,cMeta) . val2cat . actVal ---- undef
-
-actAtom :: State -> Atom
-actAtom = atomTree . actTree
-
-actFun :: State -> Err Fun
-actFun s = case actAtom s of
- AtC f -> return f
- t -> prtBad "active atom: expected function, found" t
-
-actExp :: State -> Exp
-actExp = tree2exp . actTree
-
--- | current local bindings
-actBinds :: State -> Binds
-actBinds = bindsNode . nodeTree . actTree
-
--- | constraints in current subtree
-actConstrs :: State -> Constraints
-actConstrs = allConstrsTree . actTree
-
--- | constraints in the whole tree
-allConstrs :: State -> Constraints
-allConstrs = allConstrsTree . loc2tree
-
--- | metas in current subtree
-actMetas :: State -> [Meta]
-actMetas = metasTree . actTree
-
--- | metas in the whole tree
-allMetas :: State -> [Meta]
-allMetas = metasTree . loc2tree
-
-actTreeBody :: State -> Tree
-actTreeBody = bodyTree . actTree
-
-allPrevBinds :: State -> Binds
-allPrevBinds = concatMap bindsNode . traverseCollect . actPath
-
-allBinds :: State -> Binds
-allBinds s = actBinds s ++ allPrevBinds s
-
-actGen :: State -> Int
-actGen = length . allBinds -- symbol generator for VGen
-
-allPrevVars :: State -> [Var]
-allPrevVars = map fst . allPrevBinds
-
-allVars :: State -> [Var]
-allVars = map fst . allBinds
-
-vGenIndex :: State -> Int
-vGenIndex = length . allBinds
-
-actIsMeta :: State -> Bool
-actIsMeta = atomIsMeta . actAtom
-
-actMeta :: State -> Err Meta
-actMeta = getMetaAtom . actAtom
-
--- | meta substs are not only on the actual path...
-entireMetaSubst :: State -> MetaSubst
-entireMetaSubst = concatMap metaSubstsNode . scanTree . loc2tree
-
-isCompleteTree :: Tree -> Bool
-isCompleteTree = null . filter atomIsMeta . map atomNode . scanTree
-
-isCompleteState :: State -> Bool
-isCompleteState = isCompleteTree . loc2tree
-
-initStateCat :: Context -> Cat -> Err State
-initStateCat cont cat = do
- return $ tree2loc (Tr (mkNode [] mAtom (cat2val cont cat) ([],[]), []))
-
--- | this function only concerns the body of an expression...
-annotateInState :: CGrammar -> Exp -> State -> Err Tree
-annotateInState gr exp state = do
- let binds = allBinds state
- val = actVal state
- annotateIn gr binds exp (Just val)
-
--- | ...whereas this one works with lambda abstractions
-annotateExpInState :: CGrammar -> Exp -> State -> Err Tree
-annotateExpInState gr exp state = do
- let cont = allPrevBinds state
- binds = actBinds state
- val = actVal state
- typ <- mkProdVal binds val
- annotateIn gr binds exp (Just typ)
-
-treeByExp :: (Exp -> Err Exp) -> CGrammar -> Exp -> State -> Err Tree
-treeByExp trans gr exp0 state = do
- exp <- trans exp0
- annotateExpInState gr exp state
-
--- * actions
-
-type Action = State -> Err State
-
-newCat :: CGrammar -> Cat -> Action
-newCat gr cat@(m,c) _ = do
- cont <- lookupCatContext gr m c
- testErr (null cont) "start cat must have null context" -- for easier meta refresh
- initStateCat cont cat
-
-newFun :: CGrammar -> Fun -> Action
-newFun gr fun@(m,c) _ = do
- typ <- lookupFunType gr m c
- cat <- valCat typ
- st1 <- newCat gr cat initState
- refineWithAtom True gr (qq fun) st1
-
-newTree :: Tree -> Action
-newTree t _ = return $ tree2loc t
-
-newExpTC :: CGrammar -> Exp -> Action
-newExpTC gr t s = annotate gr (refreshMetas [] t) >>= flip newTree s
-
-goNextMeta, goPrevMeta, goNextNewMeta, goPrevNewMeta, goNextMetaIfCan :: Action
-
-goNextMeta = repeatUntilErr actIsMeta goAhead -- can be the location itself
-goPrevMeta = repeatUntilErr actIsMeta goBack
-
-goNextNewMeta s = goAhead s >>= goNextMeta -- always goes away from location
-goPrevNewMeta s = goBack s >>= goPrevMeta
-
-goNextMetaIfCan = actionIfPossible goNextMeta
-
-actionIfPossible :: Action -> Action
-actionIfPossible a s = return $ errVal s (a s)
-
-goFirstMeta, goLastMeta :: Action
-goFirstMeta s = goNextMeta $ goRoot s
-goLastMeta s = goLast s >>= goPrevMeta
-
-noMoreMetas :: State -> Bool
-noMoreMetas = err (const True) (const False) . goNextMeta
-
-replaceSubTree :: Tree -> Action
-replaceSubTree tree state = changeLoc state tree
-
-refineOrReplaceWithTree :: Bool -> CGrammar -> Tree -> Action
-refineOrReplaceWithTree der gr tree state = case actMeta state of
- Ok m -> refineWithTreeReal der gr tree m state
- _ -> do
- let tree1 = addBinds (actBinds state) $ tree
- state' <- replaceSubTree tree1 state
- reCheckState gr state'
-
-refineWithTree :: Bool -> CGrammar -> Tree -> Action
-refineWithTree der gr tree state = do
- m <- errIn "move pointer to meta" $ actMeta state
- refineWithTreeReal der gr tree m state
-
-refineWithTreeReal :: Bool -> CGrammar -> Tree -> Meta -> Action
-refineWithTreeReal der gr tree m state = do
- state' <- replaceSubTree tree state
- let cs0 = allConstrs state'
- (cs,ms) = splitConstraints gr cs0
- v = vClos $ tree2exp (bodyTree tree)
- msubst = (m,v) : ms
- metaSubstRefinements gr msubst $
- mapLoc (reduceConstraintsNode gr . performMetaSubstNode msubst) state'
-
- -- without dep. types, no constraints, no grammar needed - simply: do
- -- testErr (actIsMeta state) "move pointer to meta"
- -- replaceSubTree tree state
-
-refineAllNodes :: Action -> Action
-refineAllNodes act state = do
- let estate0 = goFirstMeta state
- case estate0 of
- Bad _ -> return state
- Ok state0 -> do
- (state',n) <- tryRefine 0 state0
- if n==0
- then return state
- else actionIfPossible goFirstMeta state'
- where
- tryRefine n state = err (const $ return (state,n)) return $ do
- state' <- goNextMeta state
- meta <- actMeta state'
- case act state' of
- Ok state2 -> tryRefine (n+1) state2
- _ -> err (const $ return (state',n)) return $ do
- state2 <- goNextNewMeta state'
- tryRefine n state2
-
-uniqueRefinements :: CGrammar -> Action
-uniqueRefinements = refineAllNodes . uniqueRefine
-
-metaSubstRefinements :: CGrammar -> MetaSubst -> Action
-metaSubstRefinements gr = refineAllNodes . metaSubstRefine gr
-
-contextRefinements :: CGrammar -> Action
-contextRefinements gr = refineAllNodes contextRefine where
- contextRefine state = case varRefinementsState state of
- [(e,_)] -> refineWithAtom False gr e state
- _ -> Bad "no unique refinement in context"
- varRefinementsState state =
- [r | r@(e,_) <- refinementsState gr state, isVariable e]
-
-uniqueRefine :: CGrammar -> Action
-uniqueRefine gr state = case refinementsState gr state of
- [(e,(_,True))] -> Bad "only circular refinement"
- [(e,_)] -> refineWithAtom False gr e state
- _ -> Bad "no unique refinement"
-
-metaSubstRefine :: CGrammar -> MetaSubst -> Action
-metaSubstRefine gr msubst state = do
- m <- errIn "move pointer to meta" $ actMeta state
- case lookup m msubst of
- Just v -> do
- e <- val2expSafe v
- refineWithExpTC False gr e state
- _ -> Bad "no metavariable substitution available"
-
-refineWithExpTC :: Bool -> CGrammar -> Exp -> Action
-refineWithExpTC der gr exp0 state = do
- let oldmetas = allMetas state
- exp = refreshMetas oldmetas exp0
- tree0 <- annotateInState gr exp state
- let tree = addBinds (actBinds state) $ tree0
- refineWithTree der gr tree state
-
-refineWithAtom :: Bool -> CGrammar -> Ref -> Action -- function or variable
-refineWithAtom der gr at state = do
- val <- lookupRef gr (allBinds state) at
- typ <- val2exp val
- let oldvars = allVars state
- exp <- ref2exp oldvars typ at
- refineWithExpTC der gr exp state
-
--- | in this command, we know that the result is well-typed, since computation
--- rules have been type checked and the result is equal
-computeSubTree :: CGrammar -> Action
-computeSubTree gr state = do
- let exp = tree2exp (actTree state)
- tree <- treeByExp (compute gr) gr exp state
- replaceSubTree tree state
-
--- | but here we don't, since the transfer flag isn't type checked,
--- and computing the transfer function is not checked to preserve equality
-transferSubTree :: Maybe Fun -> CGrammar -> Action
-transferSubTree Nothing _ s = return s
-transferSubTree (Just fun) gr state = do
- let exp = mkApp (qq fun) [tree2exp $ actTree state]
- tree <- treeByExp (compute gr) gr exp state
- state' <- replaceSubTree tree state
- reCheckState gr state'
-
-deleteSubTree :: CGrammar -> Action
-deleteSubTree gr state =
- if isRootState state
- then do
- let cat = actCat state
- newCat gr cat state
- else do
- let metas = allMetas state
- binds = actBinds state
- exp = refreshMetas metas mExp0
- tree <- annotateInState gr exp state
- state' <- replaceSubTree (addBinds binds tree) state
- reCheckState gr state' --- must be unfortunately done. 20/11/2001
-
-wrapWithFun :: CGrammar -> (Fun,Int) -> Action
-wrapWithFun gr (f@(m,c),i) state = do
- typ <- lookupFunType gr m c
- let olds = allPrevVars state
- oldmetas = allMetas state
- exp0 <- fun2wrap olds ((f,i),typ) (tree2exp (actTreeBody state))
- let exp = refreshMetas oldmetas exp0
- tree0 <- annotateInState gr exp state
- let tree = addBinds (actBinds state) $ tree0
- state' <- replaceSubTree tree state
- reCheckState gr state' --- must be unfortunately done. 20/11/2001
-
-alphaConvert :: CGrammar -> (Var,Var) -> Action
-alphaConvert gr (x,x') state = do
- let oldvars = allPrevVars state
- testErr (notElem x' oldvars) ("clash with previous bindings" +++ show x')
- let binds0 = actBinds state
- vars0 = map fst binds0
- testErr (notElem x' vars0) ("clash with other bindings" +++ show x')
- let binds = [(if z==x then x' else z, t) | (z,t) <- binds0]
- vars = map fst binds
- exp' <- alphaConv (vars ++ oldvars) (x,x') (tree2exp (actTreeBody state))
- let exp = mkAbs vars exp'
- tree <- annotateExpInState gr exp state
- replaceSubTree tree state
-
-changeFunHead :: CGrammar -> Fun -> Action
-changeFunHead gr f state = do
- let state' = changeNode (changeAtom (const (atomC f))) state
- reCheckState gr state' --- must be done because of constraints elsewhere
-
-peelFunHead :: CGrammar -> (Fun,Int) -> Action
-peelFunHead gr (f@(m,c),i) state = do
- tree0 <- nthSubtree i $ actTree state
- let tree = addBinds (actBinds state) $ tree0
- state' <- replaceSubTree tree state
- reCheckState gr state' --- must be unfortunately done. 20/11/2001
-
--- | an expensive operation
-reCheckState :: CGrammar -> State -> Err State
-reCheckState gr st = annotate gr (tree2exp (loc2tree st)) >>= return . tree2loc
-
--- | a variant that returns Bad instead of a tree with unsolvable constraints
-reCheckStateReject :: CGrammar -> State -> Err State
-reCheckStateReject gr st = do
- st' <- reCheckState gr st
- rejectUnsolvable st'
-
-rejectUnsolvable :: State -> Err State
-rejectUnsolvable st = case (constrsNode $ nodeTree $ actTree st) of
- [] -> return st
- cs -> Bad $ "Unsolvable constraints:" +++ prConstraints cs
-
--- | extract metasubstitutions from constraints and solve them
-solveAll :: CGrammar -> State -> Err State
-solveAll gr st = solve st >>= solve where
- solve st0 = do ---- why need twice?
- st <- reCheckState gr st0
- let cs0 = allConstrs st
- (cs,ms) = splitConstraints gr cs0
- metaSubstRefinements gr ms $
- mapLoc (reduceConstraintsNode gr . performMetaSubstNode ms) st
-
--- * active refinements
-
-refinementsState :: CGrammar -> State -> [(Term,(Val,Bool))]
-refinementsState gr state =
- let filt = possibleRefVal gr state in
- if actIsMeta state
- then refsForType filt gr (allBinds state) (actVal state)
- else []
-
-wrappingsState :: CGrammar -> State -> [((Fun,Int),Type)]
-wrappingsState gr state
- | actIsMeta state = []
- | isRootState state = funs
- | otherwise = [rule | rule@(_,typ) <- funs, possibleRefVal gr state aval typ]
- where
- funs = funsOnType (possibleRefVal gr state) gr aval
- aval = actVal state
-
-peelingsState :: CGrammar -> State -> [(Fun,Int)]
-peelingsState gr state
- | actIsMeta state = []
- | isRootState state =
- err (const []) (\f -> [(f,i) | i <- [0 .. arityTree tree - 1]]) $ actFun state
- | otherwise =
- err (const [])
- (\f -> [fi | (fi@(g,_),typ) <- funs,
- possibleRefVal gr state aval typ,g==f]) $ actFun state
- where
- funs = funsOnType (possibleRefVal gr state) gr aval
- aval = actVal state
- tree = actTree state
-
-headChangesState :: CGrammar -> State -> [Fun]
-headChangesState gr state = errVal [] $ do
- f@(m,c) <- funAtom (actAtom state)
- typ0 <- lookupFunType gr m c
- return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0]
- --- alpha-conv !
-
-possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool
-possibleRefVal gr state val typ = errVal True $ do --- was False
- vtyp <- valType typ
- let gen = actGen state
- cs <- return [(val, vClos vtyp)] --- eqVal gen val (vClos vtyp) --- only poss cs
- return $ possibleConstraints gr cs --- a simple heuristic
-
-possibleTreeVal :: CGrammar -> State -> Tree -> Bool
-possibleTreeVal gr state tree = errVal True $ do --- was False
- let aval = actVal state
- let gval = valTree tree
- let gen = actGen state
- cs <- return [(aval, gval)] --- eqVal gen val (vClos vtyp) --- only poss cs
- return $ possibleConstraints gr cs --- a simple heuristic
-
diff --git a/src-3.0/GF/UseGrammar/Generate.hs b/src-3.0/GF/UseGrammar/Generate.hs
deleted file mode 100644
index 5f07e0b85..000000000
--- a/src-3.0/GF/UseGrammar/Generate.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Generate
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/12 12:38:30 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
---
--- Generate all trees of given category and depth. AR 30\/4\/2004
---
--- (c) Aarne Ranta 2004 under GNU GPL
---
--- Purpose: to generate corpora. We use simple types and don't
--- guarantee the correctness of bindings\/dependences.
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Generate (generateTrees,generateAll) where
-
-import GF.Canon.GFC
-import GF.Grammar.LookAbs
-import GF.Grammar.PrGrammar
-import GF.Grammar.Macros
-import GF.Grammar.Values
-import GF.Grammar.Grammar (Cat)
-import GF.Grammar.SGrammar
-import GF.Data.Operations
-import GF.Data.Zipper
-import GF.Infra.Option
-import Data.List
-
--- Generate all trees of given category and depth. AR 30/4/2004
--- (c) Aarne Ranta 2004 under GNU GPL
---
--- Purpose: to generate corpora. We use simple types and don't
--- guarantee the correctness of bindings/dependences.
-
-
--- | the main function takes an abstract syntax and returns a list of trees
-generateTrees ::
- Options -> GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
-generateTrees opts gr cat n mn mt = map str2tr $ generate gr' opts cat' n mn mt'
- where
- gr' = gr2sgr opts emptyProbs gr
- cat' = prt $ snd cat
- mt' = maybe Nothing (return . tr2str) mt
---- ifm = oElem withMetas opts
- ifm = oElem showOld opts
-
-generateAll :: Options -> (Exp -> IO ()) -> GFCGrammar -> Cat -> IO ()
-generateAll opts io gr cat = mapM_ (io . str2tr) $ num $ gen cat'
- where
- num = optIntOrAll opts flagNumber
- gr' = gr2sgr opts emptyProbs gr
- cat' = prt $ snd cat
- gen c = generate gr' opts c 10 Nothing Nothing
-
-
-
-------------------------------------------
--- do the main thing with a simpler data structure
--- the first Int gives tree depth, the second constrains subtrees
--- chosen for each branch. A small number, such as 2, is a good choice
--- if the depth is large (more than 3)
--- If a tree is given as argument, generation concerns its metavariables.
-
-generate :: SGrammar -> Options -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree]
-generate gr opts cat i mn mt = case mt of
- Nothing -> gen opts cat
- Just t -> genM t
- where
---- now use ifm to choose between two algorithms
- gen opts cat
- | oElem (iOpt "mem") opts = concat $ errVal [] $ lookupTree id cat $ allTrees -- -old
- | oElem (iOpt "nonub") opts = concatMap (\i -> gener i cat) [0..i-1] -- some duplicates
- | otherwise = nub $ concatMap (\i -> gener i cat) [0..i-1] -- new
-
- gener 0 c = [SApp (f, []) | (f,([],_)) <- funs c]
- gener i c = [
- tr |
- (f,(cs,_)) <- funs c,
- let alts = map (gener (i-1)) cs,
- ts <- combinations alts,
- let tr = SApp (f, ts)
--- depth tr >= i -- NO!
- ]
-
- allTrees = genAll i
-
- -- dynamic generation
- genAll :: Int -> BinTree SCat [[STree]]
- genAll i = iter i genNext (mapTree (\ (c,_) -> (c,[[]])) gr)
-
- iter 0 f tr = tr
- iter n f tr = iter (n-1) f (f tr)
-
- genNext tr = mapTree (genNew tr) tr
-
- genNew tr (cat,ts) = let size = length ts in
- (cat, [SApp (f, xs) |
- (f,(cs,_)) <- funs cat,
- xs <- combinations (map look cs),
- let fxs = SApp (f, xs),
- depth fxs == size]
- : ts)
- where
- look c = concat $ errVal [] $ lookupTree id c tr
-
- funs cat = maybe id take mn $ errVal [] $ lookupTree id cat gr
-
- genM t = case t of
- SApp (f,ts) -> [SApp (f,ts') | ts' <- combinations (map genM ts)]
- SMeta k -> gen opts k
- _ -> [t]
diff --git a/src-3.0/GF/UseGrammar/GetTree.hs b/src-3.0/GF/UseGrammar/GetTree.hs
deleted file mode 100644
index e980a3d95..000000000
--- a/src-3.0/GF/UseGrammar/GetTree.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GetTree
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/15 16:22:02 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.9 $
---
--- how to form linearizable trees from strings and from terms of different levels
---
--- 'String' --> raw 'Term' --> annot, qualif 'Term' --> 'Tree'
------------------------------------------------------------------------------
-
-module GF.UseGrammar.GetTree where
-
-import GF.Canon.GFC
-import GF.Grammar.Values
-import qualified GF.Grammar.Grammar as G
-import GF.Infra.Ident
-import GF.Grammar.MMacros
-import GF.Grammar.Macros
-import GF.Compile.Rename
-import GF.Grammar.TypeCheck
-import GF.Grammar.AbsCompute (beta)
-import GF.Compile.PGrammar
-import GF.Compile.ShellState
-
-import GF.Data.Operations
-
-import Data.Char
-
--- how to form linearizable trees from strings and from terms of different levels
---
--- String --> raw Term --> annot, qualif Term --> Tree
-
-string2tree :: StateGrammar -> String -> Tree
-string2tree gr = errVal uTree . string2treeErr gr
-
-string2treeErr :: StateGrammar -> String -> Err Tree
-string2treeErr _ "" = Bad "empty string"
-string2treeErr gr s = do
- t <- pTerm s
- let t0 = beta [] t
- let t1 = refreshMetas [] t0
- let t2 = qualifTerm abstr t1
- annotate grc t2
- where
- abstr = absId gr
- grc = grammar gr
-
-string2Cat, string2Fun :: StateGrammar -> String -> (Ident,Ident)
-string2Cat gr c = (absId gr,identC c)
-string2Fun = string2Cat
-
-strings2Cat, strings2Fun :: String -> (Ident,Ident)
-strings2Cat s = (identC m, identC (drop 1 c)) where (m,c) = span (/= '.') s
-strings2Fun = strings2Cat
-
-string2ref :: StateGrammar -> String -> Err G.Term
-string2ref gr s = case s of
- 'x':'_':ds -> return $ freshAsTerm ds --- hack for generated vars
- '"':_:_ -> return $ G.K $ init $ tail s
- _:_ | all isDigit s -> return $ G.EInt $ read s
- _ | elem '.' s -> return $ uncurry G.Q $ strings2Fun s
- _ -> return $ G.Vr $ identC s
-
-string2cat :: StateGrammar -> String -> Err G.Cat
-string2cat gr s =
- if elem '.' s
- then return $ strings2Fun s
- else return $ curry id (absId gr) (identC s)
diff --git a/src-3.0/GF/UseGrammar/Information.hs b/src-3.0/GF/UseGrammar/Information.hs
deleted file mode 100644
index 4526980d6..000000000
--- a/src-3.0/GF/UseGrammar/Information.hs
+++ /dev/null
@@ -1,162 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Information
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/05 20:02:20 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
---
--- information on module, category, function, operation, parameter,...
--- AR 16\/9\/2003.
--- uses source grammar
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Information (
- showInformation,
- missingLinCanonGrammar
- ) where
-
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Infra.Option
-import GF.CF.CF
-import GF.CF.PPrCF
-import GF.Compile.ShellState
-import GF.Grammar.PrGrammar
-import GF.Grammar.Lookup
-import GF.Grammar.Macros (zIdent)
-import qualified GF.Canon.GFC as GFC
-import qualified GF.Canon.AbsGFC as AbsGFC
-
-import GF.Data.Operations
-import GF.Infra.UseIO
-
--- information on module, category, function, operation, parameter,... AR 16/9/2003
--- uses source grammar
-
--- | the top level function
-showInformation :: Options -> ShellState -> Ident -> IOE ()
-showInformation opts st c = do
- is <- ioeErr $ getInformation opts st c
- if null is
- then putStrLnE "Identifier not in scope"
- else mapM_ (putStrLnE . prInformationM c) is
- where
- prInformationM c (i,m) = prInformation opts c i ++ "file:" +++ m ++ "\n"
-
--- | the data type of different kinds of information
-data Information =
- IModAbs SourceAbs
- | IModRes SourceRes
- | IModCnc SourceCnc
- | IModule SourceAbs -- ^ to be deprecated
- | ICatAbs Ident Context [Ident]
- | ICatCnc Ident Type [CFRule] Term
- | IFunAbs Ident Type (Maybe Term)
- | IFunCnc Ident Type [CFRule] Term
- | IOper Ident Type Term
- | IParam Ident [Param] [Term]
- | IValue Ident Type
-
-type CatId = AbsGFC.CIdent
-type FunId = AbsGFC.CIdent
-
-prInformation :: Options -> Ident -> Information -> String
-prInformation opts c i = unlines $ prt c : case i of
- IModule m -> [
- "module of type" +++ show (mtype m),
- "extends" +++ show (extends m),
- "opens" +++ show (opens m),
- "defines" +++ unwords (map prt (ownConstants (jments m)))
- ]
- ICatAbs m co _ -> [
- "category in abstract module" +++ prt m,
- if null co then "not a dependent type"
- else "dependent type with context" +++ prContext co
- ]
- ICatCnc m ty cfs tr -> [
- "category in concrete module" +++ prt m,
- "linearization type" +++ prt ty
- ]
- IFunAbs m ty _ -> [
- "function in abstract module" +++ prt m,
- "type" +++ prt ty
- ]
- IFunCnc m ty cfs tr -> [
- "function in concrete module" +++ prt m,
- "linearization" +++ prt tr
- --- "linearization type" +++ prt ty
- ]
- IOper m ty tr -> [
- "operation in resource module" +++ prt m,
- "type" +++ prt ty,
- "definition" +++ prt tr
- ]
- IParam m ty ts -> [
- "parameter type in resource module" +++ prt m,
- "constructors" +++ unwords (map prParam ty),
- "values" +++ unwords (map prt ts)
- ]
- IValue m ty -> [
- "parameter constructor in resource module" +++ prt m,
- "type" +++ show ty
- ]
-
--- | also finds out if an identifier is defined in many places
-getInformation :: Options -> ShellState -> Ident -> Err [(Information,FilePath)]
-getInformation opts st c = allChecks $ [
- do
- m <- lookupModule src c
- case m of
- ModMod mo -> returnm c $ IModule mo
- _ -> prtBad "not a source module" c
- ] ++ map lookInSrc ss ++ map lookInCan cs
- where
- lookInSrc (i,m) = do
- j <- lookupInfo m c
- case j of
- AbsCat (Yes co) _ -> returnm i $ ICatAbs i co [] ---
- AbsFun (Yes ty) _ -> returnm i $ IFunAbs i ty Nothing ---
- CncCat (Yes ty) _ _ -> do
- ---- let cat = ident2CFCat i c
- ---- rs <- concat [rs | (c,rs) <- cf, ]
- returnm i $ ICatCnc i ty [] ty ---
- CncFun _ (Yes tr) _ -> do
- rs <- return []
- returnm i $ IFunCnc i tr rs tr ---
- ResOper (Yes ty) (Yes tr) -> returnm i $ IOper i ty tr
- ResParam (Yes (ps,_)) -> do
- ts <- allParamValues src (QC i c)
- returnm i $ IParam i ps ts
- ResValue (Yes (ty,_)) -> returnm i $ IValue i ty ---
-
- _ -> prtBad "nothing available for" i
- lookInCan (i,m) = do
- Bad "nothing available yet in canonical"
-
- returnm m i = return (i, pathOfModule st m)
-
- src = srcModules st
- can = canModules st
- ss = [(i,m) | (i,ModMod m) <- modules src]
- cs = [(i,m) | (i,ModMod m) <- modules can]
- cf = concatMap ruleGroupsOfCF $ map snd $ cfs st
-
-ownConstants :: BinTree Ident Info -> [Ident]
-ownConstants = map fst . filter isOwn . tree2list where
- isOwn (c,i) = case i of
- AnyInd _ _ -> False
- _ -> True
-
-missingLinCanonGrammar :: GFC.CanonGrammar -> String
-missingLinCanonGrammar cgr =
- unlines $ concat [prt_ c : missing js | (c,js) <- concretes] where
- missing js = map ((" " ++) . prt_) $ filter (not . flip isInBinTree js) abstract
- abstract = err (const []) (map fst . tree2list . jments) $ lookupModMod cgr absId
- absId = maybe (zIdent "") id $ greatestAbstract cgr
- concretes = [(cnc,jments mo) |
- cnc <- allConcretes cgr absId, Ok mo <- [lookupModMod cgr cnc]]
diff --git a/src-3.0/GF/UseGrammar/Linear.hs b/src-3.0/GF/UseGrammar/Linear.hs
deleted file mode 100644
index c9b94ccb0..000000000
--- a/src-3.0/GF/UseGrammar/Linear.hs
+++ /dev/null
@@ -1,292 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Linear
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/14 16:03:41 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.19 $
---
--- Linearization for canonical GF. AR 7\/6\/2003
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Linear where
-
-import GF.Canon.GFC
-import GF.Canon.AbsGFC
-import qualified GF.Grammar.Abstract as A
-import GF.Canon.MkGFC (rtQIdent) ----
-import GF.Infra.Ident
-import GF.Grammar.PrGrammar
-import GF.Canon.CMacros
-import GF.Canon.Look
-import GF.Grammar.LookAbs
-import GF.Grammar.MMacros
-import GF.Grammar.TypeCheck (annotate) ----
-import GF.Data.Str
-import GF.Text.Text
-----import TypeCheck -- to annotate
-
-import GF.Data.Operations
-import GF.Data.Zipper
-import qualified GF.Infra.Modules as M
-
-import Control.Monad
-import Data.List (intersperse)
-
--- Linearization for canonical GF. AR 7/6/2003
-
--- | The worker function: linearize a Tree, return
--- a record. Possibly mark subtrees.
---
--- NB. Constants in trees are annotated by the name of the abstract module.
--- A concrete module name must be given to find (and choose) linearization rules.
---
--- - If no marking is wanted, 'noMark' :: 'Marker'.
---
--- - For xml marking, use 'markXML' :: 'Marker'
-linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
-linearizeToRecord gr mk m = lin [] where
-
- lin ts t@(Tr (n,xs)) = errIn ("linearization of" +++ prt t) $ do
-
- let binds = A.bindsNode n
- at = A.atomNode n
- fmk = markSubtree mk n ts (A.isFocusNode n)
- c <- A.val2cat $ A.valNode n
- xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
-
- r <- case at of
- A.AtC f -> lookf c t f >>= comp xs'
- A.AtI i -> return $ recInt i
- A.AtL s -> return $ recS $ tK $ prt at
- A.AtF i -> return $ recS $ tK $ prt at
- A.AtV x -> lookCat c >>= comp [tK (prt_ at)]
- A.AtM m -> lookCat c >>= comp [tK (prt_ at)]
-
- r' <- case r of -- to see stg in case the result is variants {}
- FV [] -> lookCat c >>= comp [tK (prt_ t)]
- _ -> return r
-
- return $ fmk $ mkBinds binds r'
-
- look = lookupLin gr . redirectIdent m . rtQIdent
- comp = ccompute gr
- mkBinds bs bdy = case bdy of
- R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs
- FV rs -> FV $ map (mkBinds bs) rs
-
- recS t = R [Ass (L (identC "s")) t] ----
-
- recInt i = R [
- Ass (L (identC "last")) (EInt (rem i 10)),
- Ass (L (identC "s")) (tK $ show i),
- Ass (L (identC "size")) (EInt (if i > 9 then 1 else 0))
- ]
-
- lookCat = return . errVal defLindef . look
- ---- should always be given in the module
-
- -- to show missing linearization as term
- lookf c t f = case look f of
- Ok h -> return h
- _ -> lookCat c >>= comp [tK (prt_ t)]
-
-
--- | thus the special case:
-linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term
-linearizeNoMark gr = linearizeToRecord gr noMark
-
--- | expand tables in linearized term to full, normal-order tables
---
--- NB expand from inside-out so that values are not looked up in copies of branches
-
-expandLinTables :: CanonGrammar -> Term -> Err Term
-expandLinTables gr t = case t of
- R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
- T ty rs -> do
- rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out
- let t' = T ty $ map (uncurry Cas) rs'
- vs <- alls ty
- ps <- mapM term2patt vs
- ts' <- mapM (comp . S t') $ vs
- return $ T ty [Cas [p] t | (p,t) <- zip ps ts']
- V ty ts0 -> do
- ts <- mapM exp ts0 -- expand from inside-out
- vs <- alls ty
- ps <- mapM term2patt vs
- return $ T ty [Cas [p] t | (p,t) <- zip ps ts]
- FV ts -> liftM FV $ mapM exp ts
- _ -> composOp exp t
- where
- alls = allParamValues gr
- exp = expandLinTables gr
- comp = ccompute gr []
-
--- Do this for an entire grammar:
-
-unoptimizeCanon :: CanonGrammar -> CanonGrammar
-unoptimizeCanon g@(M.MGrammar ms) = M.MGrammar $ map (unoptimizeCanonMod g) ms
-
-unoptimizeCanonMod :: CanonGrammar -> CanonModule -> CanonModule
-unoptimizeCanonMod g = convMod where
- convMod (m, M.ModMod (M.Module (M.MTConcrete a) x flags me os defs)) =
- (m, M.ModMod (M.Module (M.MTConcrete a) x flags me os (mapTree convDef defs)))
- convMod mm = mm
- convDef (c,CncCat ty df pr) = (c,CncCat ty (convT df) (convT pr))
- convDef (f,CncFun c xs li pr) = (f,CncFun c xs (convT li) (convT pr))
- convDef cd = cd
- convT = err error id . exp
- -- a version of expandLinTables that does not destroy share optimization
- exp t = case t of
- R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
- T ty rs@[Cas [_] _] -> do
- rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out
- let t' = T ty $ map (uncurry Cas) rs'
- vs <- alls ty
- ps <- mapM term2patt vs
- ts' <- mapM (comp . S t') $ vs
- return $ T ty [Cas [p] t | (p,t) <- zip ps ts']
- V ty ts0 -> do
- ts <- mapM exp ts0 -- expand from inside-out
- vs <- alls ty
- ps <- mapM term2patt vs
- return $ T ty [Cas [p] t | (p,t) <- zip ps ts]
- FV ts -> liftM FV $ mapM exp ts
- I _ -> comp t
- _ -> composOp exp t
- where
- alls = allParamValues g
- comp = ccompute g []
-
-
--- | from records, one can get to records of tables of strings
-rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]]
-rec2strTables r = do
- vs <- allLinValues r
- mapM (mapPairsM (mapPairsM strsFromTerm)) vs
-
--- | from these tables, one may want to extract the ones for the "s" label
-strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]]
-strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0]
-
-linLab0 :: Label
-linLab0 = L (identC "s")
-
--- | to get lists of token lists is easy
-sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
-sTables2strs = map snd . concat
-
--- | from this, to get a list of strings
-strs2strings :: [[Str]] -> [String]
-strs2strings = map unlex
-
--- | this is just unwords; use an unlexer from Text to postprocess
-unlex :: [Str] -> String
-unlex = concat . map sstr . take 1 ----
-
--- | finally, a top-level function to get a string from an expression
-linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
-linTree2string mk gr m e = head $ linTree2strings mk gr m e -- never empty
-
--- | you can also get many strings
-linTree2strings :: Marker -> CanonGrammar -> Ident -> A.Tree -> [String]
-linTree2strings mk gr m e = err return id $ do
- t <- linearizeToRecord gr mk m e
- r <- expandLinTables gr t
- ts <- rec2strTables r
- let ss = strs2strings $ sTables2strs $ strTables2sTables ts
- ifNull (prtBad "empty linearization of" e) return ss -- thus never empty
-
--- | argument is a Tree, value is a list of strs; needed in Parsing
-allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str]
-allLinsOfTree gr a e = err (singleton . str) id $ do
- e' <- return e ---- annotateExp gr e
- r <- linearizeNoMark gr a e'
- r' <- expandLinTables gr r
- ts <- rec2strTables r'
- return $ concat $ sTables2strs $ strTables2sTables ts
-
--- | the value is a list of structures arranged as records of tables of terms
-allLinsAsRec :: CanonGrammar -> Ident -> A.Tree -> Err [[(Label,[([Patt],Term)])]]
-allLinsAsRec gr c t = linearizeNoMark gr c t >>= expandLinTables gr >>= allLinValues
-
--- | the value is a list of structures arranged as records of tables of strings
--- only taking into account string fields
--- True: sep. by /, False: sep by \n
-allLinTables ::
- Bool -> CanonGrammar ->Ident ->A.Tree ->Err [[(Label,[([Patt],[String])])]]
-allLinTables slash gr c t = do
- r' <- allLinsAsRec gr c t
- mapM (mapM getS) r'
- where
- getS (lab,pss) = liftM (curry id lab) $ mapM gets pss
- gets (ps,t) = liftM (curry id ps . cc . map str2strings) $ strsFromTerm t
- cc = concat . intersperse [if slash then "/" else "\n"]
-
--- | the value is a list of strings gathered from all fields
-
-allLinBranchFields :: CanonGrammar -> Ident -> A.Tree -> Err [String]
-allLinBranchFields gr c trm = do
- r <- linearizeNoMark gr c trm >>= expandLinTables gr
- return [s | (_,t) <- allLinBranches r, s <- gets t]
- where
- gets t = concat [cc (map str2strings s) | Ok s <- [strsFromTerm t]]
- cc = concat . intersperse ["/"]
-
-prLinTable :: Bool -> [[(Label,[([Patt],[String])])]] -> [String]
-prLinTable pars = concatMap prOne . concat where
- prOne (lab,pss) = (if pars then ((prt lab) :) else id) (map pr pss) ----
- pr (ps,ss) = (if pars then ((unwords (map prt_ ps) +++ ":") +++)
- else id) (unwords ss)
-
-{-
--- the value is a list of strs
-allLinStrings :: CanonGrammar -> Tree -> [Str]
-allLinStrings gr ft = case allLinsAsStrs gr ft of
- Ok ts -> map snd $ concat $ map snd $ concat ts
- Bad s -> [str s]
-
--- the value is a list of strs, not forgetting their arguments
-allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]]
-allLinsAsStrs gr ft = do
- lpts <- allLinearizations gr ft
- return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts
-
-
--- to a list of strings
-linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String]
-linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk
-
--- to a list of token lists
-linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]]
-linearizeToStrss gr mk e = do
- R rs <- linearizeToRecord gr mk e ----
- t <- lookupErr linLab0 [(r,s) | Ass r s <- rs]
- return $ map strsFromTerm $ allInTable t
--}
-
--- | the value is a list of strings, not forgetting their arguments
-allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]]
-allLinsOfFun gr f = do
- t <- lookupLin gr f
- allAllLinValues t --- all fields, not only s. 11/12/2005
-
-
--- | returns printname if one exists; otherwise linearizes with metas
-printOrLinearize :: CanonGrammar -> Ident -> A.Fun -> String
-printOrLinearize gr c f@(m, d) = errVal (prt fq) $
- case lookupPrintname gr (CIQ c d) of
- Ok t -> do
- ss <- strsFromTerm t
- let s = strs2strings [ss]
- return $ ifNull (prt fq) head s
- _ -> do
- ty <- lookupFunType gr m d
- f' <- ref2exp [] ty (A.QC m d)
- tr <- annotate gr f'
- return $ linTree2string noMark gr c tr
- where
- fq = CIQ m d
diff --git a/src-3.0/GF/UseGrammar/MatchTerm.hs b/src-3.0/GF/UseGrammar/MatchTerm.hs
deleted file mode 100644
index 9acffd44c..000000000
--- a/src-3.0/GF/UseGrammar/MatchTerm.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : MatchTerm
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
---
--- functions for matching with terms. AR 16/3/2006
------------------------------------------------------------------------------
-
-module GF.UseGrammar.MatchTerm where
-
-import GF.Data.Operations
-import GF.Data.Zipper
-
-import GF.Grammar.Grammar
-import GF.Grammar.PrGrammar
-import GF.Infra.Ident
-import GF.Grammar.Values
-import GF.Grammar.Macros
-import GF.Grammar.MMacros
-
-import Control.Monad
-import Data.List
-
--- test if a term has duplicated idents, either any or just atoms
-
-hasDupIdent, hasDupAtom :: Exp -> Bool
-hasDupIdent = (>1) . maximum . map length . group . sort . allConstants True
-hasDupAtom = (>1) . maximum . map length . group . sort . allConstants False
-
--- test if a certain ident occurs in term
-
-grepIdent :: Ident -> Exp -> Bool
-grepIdent c = elem c . allConstants True
-
--- form the list of all constants, optionally ignoring all but atoms
-
-allConstants :: Bool -> Exp -> [Ident]
-allConstants alsoApp = err (const []) snd . flip appSTM [] . collect where
- collect e = case e of
- Q _ c -> add c e
- QC _ c -> add c e
- Cn c -> add c e
- App f a | not alsoApp -> case f of
- App g b -> collect b >> collect a
- _ -> collect a
- _ -> composOp collect e
- add c e = updateSTM (c:) >> return e
diff --git a/src-3.0/GF/UseGrammar/Morphology.hs b/src-3.0/GF/UseGrammar/Morphology.hs
deleted file mode 100644
index 3aeb08dc7..000000000
--- a/src-3.0/GF/UseGrammar/Morphology.hs
+++ /dev/null
@@ -1,140 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Morphology
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:49 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.8 $
---
--- Morphological analyser constructed from a GF grammar.
---
--- we first found the binary search tree sorted by word forms more efficient
--- than a trie, at least for grammars with 7000 word forms
--- (18\/11\/2003) but this may change since we have to use a trie
--- for decompositions and also want to use it in the parser
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Morphology where
-
-import GF.Canon.AbsGFC
-import GF.Canon.GFC
-import GF.Grammar.PrGrammar
-import GF.Canon.CMacros
-import GF.Canon.Look
-import GF.Grammar.LookAbs
-import GF.Infra.Ident
-import qualified GF.Grammar.Macros as M
-import GF.UseGrammar.Linear
-
-import GF.Data.Operations
-import GF.Data.Glue
-
-import Data.Char
-import Data.List (sortBy, intersperse)
-import Control.Monad (liftM)
-import GF.Data.Trie2
-
--- construct a morphological analyser from a GF grammar. AR 11/4/2001
-
--- we first found the binary search tree sorted by word forms more efficient
--- than a trie, at least for grammars with 7000 word forms
--- (18\/11\/2003) but this may change since we have to use a trie
--- for decompositions and also want to use it in the parser
-
-type Morpho = Trie Char String
-
-emptyMorpho :: Morpho
-emptyMorpho = emptyTrie
-
-appMorpho :: Morpho -> String -> (String,[String])
-appMorpho = appMorphoOnly
----- add lookup for literals
-
--- without literals
-appMorphoOnly :: Morpho -> String -> (String,[String])
-appMorphoOnly m s = trieLookup m s
-
--- recognize word, exluding literals
-isKnownWord :: Morpho -> String -> Bool
-isKnownWord mo = not . null . snd . appMorphoOnly mo
-
-mkMorpho :: CanonGrammar -> Ident -> Morpho
-mkMorpho gr a = tcompile $ concatMap mkOne $ allItems where
-
- comp = ccompute gr [] -- to undo 'values' optimization
-
- mkOne (Left (fun,c)) = map (prOne fun c) $ allLins fun
- mkOne (Right (fun,_)) = map (prSyn fun) $ allSyns fun
-
- -- gather forms of lexical items
- allLins fun@(m,f) = errVal [] $ do
- ts <- lookupLin gr (CIQ a f) >>= comp >>= allAllLinValues
- ss <- mapM (mapPairsM (mapPairsM (liftM wordsInTerm . comp))) ts
- return [(p,s) | (p,fs) <- concat $ map snd $ concat ss, s <- fs]
- prOne (_,f) c (ps,s) = (s, [prt f +++ tagPrt c +++ unwords (map prt_ ps)])
-
- -- gather syncategorematic words
- allSyns fun@(m,f) = errVal [] $ do
- tss <- allLinsOfFun gr (CIQ a f)
- let ss = [s | ts <- tss, (_,fs) <- ts, (_,s) <- fs]
- return $ concat $ map wordsInTerm ss
- prSyn f s = (s, ["+<syncategorematic>" ++ tagPrt f])
-
- -- all words, Left from lexical rules and Right syncategorematic
- allItems = [lexRole t (f,c) | (f,c,t) <- allFuns] where
- allFuns = [(f,c,t) | (f,t) <- funRulesOf gr, Ok c <- [M.valCat t]]
- lexRole t = case M.typeForm t of
- Ok ([],_,_) -> Left
- _ -> Right
-
--- printing full-form lexicon and results
-
-prMorpho :: Morpho -> String
-prMorpho = unlines . map prMorphoAnalysis . collapse
-
-prMorphoAnalysis :: (String,[String]) -> String
-prMorphoAnalysis (w,fs0) =
- let fs = filter (not . null) fs0 in
- if null fs then w ++++ "*" else unlines (w:fs)
-
-prMorphoAnalysisShort :: (String,[String]) -> String
-prMorphoAnalysisShort (w,fs) = prBracket (w' ++ prTList "/" fs) where
- w' = if null fs then w +++ "*" else ""
-
-tagPrt :: Print a => (a,a) -> String
-tagPrt (m,c) = "+" ++ prt c --- module name
-
--- | print all words recognized
-allMorphoWords :: Morpho -> [String]
-allMorphoWords = map fst . collapse
-
--- analyse running text and show results either in short form or on separate lines
-
--- | analyse running text and show just the word, with "*" if not found
-morphoTextStatus :: Morpho -> String -> String
-morphoTextStatus mo = unlines . map (prMark . appMorpho mo) . words where
- prMark (w,fs) = if null fs then "*" +++ w else w
-
--- | analyse running text and show results in short form, one word per line
-morphoTextShort :: Morpho -> String -> String
-morphoTextShort mo = unlines . map (prMorphoAnalysisShort . appMorpho mo) . words
-
--- | analyse running text and show results on separate lines
-morphoText :: Morpho -> String -> String
-morphoText mo = unlines . map (('\n':) . prMorphoAnalysis . appMorpho mo) . words
-
--- format used in the Italian Verb Engine
-prFullForm :: Morpho -> String
-prFullForm = unlines . map prOne . collapse where
- prOne (s,ps) = s ++ " : " ++ unwords (intersperse "/" ps)
-
--- using Huet's unglueing method to find word boundaries
----- it would be much better to use a trie also for morphological analysis,
----- so this is for the sake of experiment
----- Moreover, we should specify the cases in which this happens - not all words
-
-decomposeWords :: Morpho -> String -> [String]
-decomposeWords mo s = errVal (words s) $ decomposeSimple mo s
diff --git a/src-3.0/GF/UseGrammar/Paraphrases.hs b/src-3.0/GF/UseGrammar/Paraphrases.hs
deleted file mode 100644
index d04f22aa6..000000000
--- a/src-3.0/GF/UseGrammar/Paraphrases.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Paraphrases
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:49 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- paraphrases of GF terms. AR 6\/10\/1998 -- 24\/9\/1999 -- 5\/7\/2000 -- 5\/6\/2002
---
--- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL)
---
--- thus inherited from the old GF. Incomplete and inefficient...
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Paraphrases (mkParaphrases) where
-
-import GF.Grammar.Abstract
-import GF.Grammar.PrGrammar
-import GF.Grammar.LookAbs
-import GF.Grammar.AbsCompute
-
-import GF.Data.Operations
-
-import Data.List (nub)
-
--- paraphrases of GF terms. AR 6/10/1998 -- 24/9/1999 -- 5/7/2000 -- 5/6/2002
--- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL)
--- thus inherited from the old GF. Incomplete and inefficient...
-
-mkParaphrases :: GFCGrammar -> Term -> [Term]
-mkParaphrases st = nub . map (beta []) . paraphrases (allDefs st)
-
-type Definition = (Fun,Term)
-
-paraphrases :: [Definition] -> Term -> [Term]
-paraphrases th t =
- paraImmed th t ++
---- paraMatch th t ++
- case t of
- App c a -> [App d b | d <- paraphrases th c, b <- paraphrases th a]
- Abs x b -> [Abs x d | d <- paraphrases th b]
- c -> []
- ++ [t]
-
-paraImmed :: [Definition] -> Term -> [Term]
-paraImmed defs t =
- [Q m f | ((m,f), u) <- defs, t == u] ++ --- eqTerm
- case t of
- ---- Cn c -> [u | (f, u) <- defs, eqStrIdent f c]
- _ -> []
-
-{- ---
-paraMatch :: [Definition] -> Trm -> [Trm]
-paraMatch th@defs t =
- [mkApp (Cn f) xx | (PC f zz, u) <- defs,
- let (fs,sn) = fullApp u, fs == h, length sn == length zz] ++
- case findAMatch defs t of
- Ok (g,b) -> [substTerm [] g b]
- _ -> []
- where
- (h,xx) = fullApp t
- fullApp c = case c of
- App f a -> (f', a' ++ [a]) where (f',a') = fullApp f
- c -> (c,[])
-
--}
diff --git a/src-3.0/GF/UseGrammar/Parsing.hs b/src-3.0/GF/UseGrammar/Parsing.hs
deleted file mode 100644
index 2ca057410..000000000
--- a/src-3.0/GF/UseGrammar/Parsing.hs
+++ /dev/null
@@ -1,177 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Parsing
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/06/02 10:23:52 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.25 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Parsing where
-
-import GF.Infra.CheckM
-import qualified GF.Canon.AbsGFC as C
-import GF.Canon.GFC
-import GF.Canon.MkGFC (trExp) ----
-import GF.Canon.CMacros
-import GF.Grammar.MMacros (refreshMetas)
-import GF.UseGrammar.Linear
-import GF.Data.Str
-import GF.CF.CF
-import GF.CF.CFIdent
-import GF.Infra.Ident
-import GF.Grammar.TypeCheck
-import GF.Grammar.Values
---import CFMethod
-import GF.UseGrammar.Tokenize
-import GF.UseGrammar.Morphology (isKnownWord)
-import GF.CF.Profile
-import GF.Infra.Option
-import GF.UseGrammar.Custom
-import GF.Compile.ShellState
-
-import GF.CF.PPrCF (prCFTree)
--- import qualified GF.OldParsing.ParseGFC as NewOld -- OBSOLETE
-import qualified GF.Parsing.GFC as New
-
-import GF.Data.Operations
-
-import Data.List (nub,sortBy)
-import Data.Char (toLower)
-import Control.Monad (liftM)
-
--- AR 26/1/2000 -- 8/4 -- 28/1/2001 -- 9/12/2002
-
-parseString :: Options -> StateGrammar -> CFCat -> String -> Err [Tree]
-parseString os sg cat = liftM fst . parseStringMsg os sg cat
-
-parseStringMsg :: Options -> StateGrammar -> CFCat -> String -> Err ([Tree],String)
-parseStringMsg os sg cat s = do
- case checkStart $ parseStringC os sg cat s of
- Ok (ts,(_,ss)) -> return (ts, unlines $ reverse ss)
- Bad s -> return ([],s)
-
-parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree]
-parseStringC opts0 sg cat s
- | oElem (iOpt "old") opts0 ||
- (not (oElem (iOpt "fcfg") opts0) && stateHasHOAS sg) = do
- let opts = unionOptions opts0 $ stateOptions sg
- cf = stateCF sg
- gr = stateGrammarST sg
- cn = cncId sg
- toks = customOrDefault opts useTokenizer customTokenizer sg s
- parser = customOrDefault opts useParser customParser sg cat
- if oElem (iOpt "cut") opts
- then doUntil (not . null) $ map (tokens2trms opts sg cn parser) toks
- else mapM (tokens2trms opts sg cn parser) toks >>= return . concat
-
----- | or [oElem p opts0 |
----- p <- [newCParser,newMParser,newFParser,newParser,newerParser] = do
-
- | otherwise = do
- let opts = unionOptions opts0 $ stateOptions sg
- algorithm | oElem newCParser opts0 = "c"
- | oElem newMParser opts0 = "m"
- | oElem newFParser opts0 = "f"
- | otherwise = "f" -- default algorithm: FCFG
- strategy = maybe "bottomup" id $ getOptVal opts useParser
- -- -parser=bottomup/topdown
- tokenizer = customOrDefault opts useTokenizer customTokenizer sg
- toks = case tokenizer s of
- t:_ -> t
- _ -> [] ---- no support for undet. tok.
- unknowns =
- [w | TC w <- toks, unk w && unk (uncap w)] ++ [w | TS w <- toks, unk w]
- where
- unk w = not $ isKnownWord (morpho sg) w
- uncap (c:cs) = toLower c : cs
- uncap s = s
-
- case unknowns of
- _:_ | oElem (iOpt "trynextlang") opts -> return []
- _:_ -> fail $ "Unknown words:" +++ unwords unknowns
- _ -> do
-
- ts <- checkErr $ New.parse algorithm strategy (pInfo sg) (absId sg) cat toks
- ts' <- checkErr $
- allChecks $ map (annotate (stateGrammarST sg) . refreshMetas []) ts
- return $ optIntOrAll opts flagNumber ts'
-
-
-tokens2trms :: Options ->StateGrammar ->Ident -> CFParser -> [CFTok] -> Check [Tree]
-tokens2trms opts sg cn parser toks = trees2trms opts sg cn toks trees info
- where result = parser toks
- info = snd result
- trees = {- nub $ -} cfParseResults result -- peb 25/5-04: removed nub (O(n^2))
-
-trees2trms ::
- Options -> StateGrammar -> Ident -> [CFTok] -> [CFTree] -> String -> Check [Tree]
-trees2trms opts sg cn as ts0 info = do
- let s = unwords $ map prCFTok as
- ts <- case () of
- _ | null ts0 -> checkWarn ("No success in cf parsing" +++ s) >> return []
- _ | raw -> do
- ts1 <- return (map cf2trm0 ts0) ----- should not need annot
- checks [
- mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated, often fails
- ,checkWarn (unlines ("Raw CF trees:":(map prCFTree ts0))) >> return []
- ]
- _ -> do
- let num = optIntOrN opts flagRawtrees 999999
- let (ts01,rest) = splitAt num ts0
- if null rest then return ()
- else raise ("Warning: only" +++ show num +++ "raw parses out of" +++
- show (length ts0) +++
- "considered; use -rawtrees=<Int> to see more"
- )
- (ts1,ss) <- checkErr $ mapErrN 1 postParse ts01
- if null ts1 then raise ss else return ()
- ts2 <- checkErr $
- allChecks $ map (annotate gr . refreshMetas [] . trExp) ts1 ----
- if forgive then return ts2 else do
- let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2]
- ps = [t | (t,ss) <- tsss,
- any (compatToks as) (map str2cftoks ss)]
- if null ps
- then raise $ "Failure in morphology." ++
- if verb
- then "\nPossible corrections: " +++++
- unlines (nub (map sstr (concatMap snd tsss)))
- else ""
- else return ps
- if verb
- then checkWarn $ " the token list" +++ show as ++++ unknownWords sg as +++++ info
- else return ()
-
- return $ optIntOrAll opts flagNumber $ nub ts
- where
- gr = stateGrammarST sg
-
- raw = oElem rawParse opts
- verb = oElem beVerbose opts
- forgive = oElem forgiveParse opts
-
----- Operatins.allChecks :: ErrorMonad m => [m a] -> m [a]
-
-unknownWords sg ts = case filter noMatch [t | t@(TS _) <- ts] of
- [] -> "where all words are known"
- us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals
- where
- terminals = map TS $ stateGrammarWords sg
- noMatch t = all (not . compatTok t) terminals
-
-
---- too much type checking in building term info? return FullTerm to save work?
-
--- | raw parsing: so simple it is for a context-free CF grammar
-cf2trm0 :: CFTree -> C.Exp
-cf2trm0 (CFTree (fun, (_, trees))) = mkAppAtom (cffun2trm fun) (map cf2trm0 trees)
- where
- cffun2trm (CFFun (fun,_)) = fun
- mkApp = foldl C.EApp
- mkAppAtom a = mkApp (C.EAtom a)
diff --git a/src-3.0/GF/UseGrammar/Randomized.hs b/src-3.0/GF/UseGrammar/Randomized.hs
deleted file mode 100644
index c1c77edb2..000000000
--- a/src-3.0/GF/UseGrammar/Randomized.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Randomized
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:51 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.8 $
---
--- random generation and refinement. AR 22\/8\/2001.
--- implemented as sequence of refinement menu selecsions, encoded as integers
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Randomized where
-
-import GF.Grammar.Abstract
-import GF.UseGrammar.Editing
-
-import GF.Data.Operations
-import GF.Data.Zipper
-
---- import Arch (myStdGen) --- circular for hbc
-import System.Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc
-
--- random generation and refinement. AR 22/8/2001
--- implemented as sequence of refinement menu selecsions, encoded as integers
-
-myStdGen :: Int -> StdGen
-myStdGen = mkStdGen ---
-
--- | build one random tree; use mx to prevent infinite search
-mkRandomTree :: StdGen -> Int -> CGrammar -> Either Cat Fun -> Err Tree
-mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat
-
-refineRandom :: StdGen -> Int -> CGrammar -> Action
-refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen)
-
--- | build a tree from a list of integers
-mkTreeFromInts :: [Int] -> CGrammar -> Either Cat Fun -> Err Tree
-mkTreeFromInts ints gr catfun = do
- st0 <- either (\cat -> newCat gr cat initState)
- (\fun -> newFun gr fun initState)
- catfun
- state <- mkStateFromInts ints gr st0
- return $ loc2tree state
-
-mkStateFromInts :: [Int] -> CGrammar -> Action
-mkStateFromInts ints gr z = mkRandomState ints z >>= reCheckState gr where
- mkRandomState [] state = do
- testErr (isCompleteState state) "not completed"
- return state
- mkRandomState (n:ns) state = do
- let refs = refinementsState gr state
- refs0 = map (not . snd . snd) refs
- testErr (not (null refs0)) $ "no nonrecursive refinements available for" +++
- prt (actVal state)
- (ref,_) <- (refs !? (n `mod` (length refs)))
- state1 <- refineWithAtom False gr ref state
- if isCompleteState state1
- then return state1
- else do
- state2 <- goNextMeta state1
- mkRandomState ns state2
-
diff --git a/src-3.0/GF/UseGrammar/Session.hs b/src-3.0/GF/UseGrammar/Session.hs
deleted file mode 100644
index e54d0e3fb..000000000
--- a/src-3.0/GF/UseGrammar/Session.hs
+++ /dev/null
@@ -1,181 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Session
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/08/17 15:13:55 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.12 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Session where
-
-import GF.Grammar.Abstract
-import GF.Infra.Option
-import GF.UseGrammar.Custom
-import GF.UseGrammar.Editing
-import GF.Compile.ShellState ---- grammar
-
-import GF.Data.Operations
-import GF.Data.Zipper (keepPosition) ---
-
--- First version 8/2001. Adapted to GFC with modules 19/6/2003.
--- Nothing had to be changed, which is a sign of good modularity.
-
--- keep these abstract
-
--- | 'Exp'-list: candidate refinements,clipboard
-type SState = [(State,([Exp],[Clip]),SInfo)]
-
--- | 'String' is message, 'Int' is the view
-type SInfo = ([String],(Int,Options))
-
-initSState :: SState
-initSState = [(initState, ([],[]), (["Select 'New' category to start"],(0,noOptions)))]
- -- instead of empty
-
-type Clip = Tree ---- (Exp,Type)
-
--- | (peb): Something wrong with this definition??
--- Shouldn't the result type be 'SInfo'?
---
--- > okInfo :: Int -> SInfo == ([String], (Int, Options))
-okInfo :: n -> ([s], (n, Bool))
-okInfo n = ([],(n,True))
-
-stateSState :: SState -> State
-candsSState :: SState -> [Exp]
-clipSState :: SState -> [Clip]
-infoSState :: SState -> SInfo
-msgSState :: SState -> [String]
-viewSState :: SState -> Int
-optsSState :: SState -> Options
-
-stateSState ((s,_,_):_) = s
-candsSState ((_,(ts,_),_):_)= ts
-clipSState ((_,(_,ts),_):_)= ts
-infoSState ((_,_,i):_) = i
-msgSState ((_,_,(m,_)):_) = m
-viewSState ((_,_,(_,(v,_))):_) = v
-optsSState ((_,_,(_,(_,o))):_) = o
-
-treeSState :: SState -> Tree
-treeSState = actTree . stateSState
-
-
--- | from state to state
-type ECommand = SState -> SState
-
--- * elementary commands
-
--- ** change state, drop cands, drop message, preserve options
-
-changeState :: State -> ECommand
-changeState s ss = changeMsg [] $ (s,([],clipSState ss),infoSState ss) : ss
-
-changeCands :: [Exp] -> ECommand
-changeCands ts ss@((s,(_,cb),(_,b)):_) = (s,(ts,cb),(candInfo ts,b)) : ss
-
-addtoClip :: Clip -> ECommand
-addtoClip t ss@((s,(ts,cb),(i,b)):_) = (s,(ts,t:cb),(i,b)) : ss
-
-removeClip :: Int -> ECommand
-removeClip n ss@((s,(ts,cb),(i,b)):_) = (s,(ts, drop n cb),(i,b)) : ss
-
-changeMsg :: [String] -> ECommand
-changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss -- just change message
-changeMsg m _ = (s,ts,(m,b)) : [] where [(s,ts,(_,b))] = initSState
-
-changeView :: ECommand
-changeView ((s,ts,(m,(v,b))):ss) = (s,ts,(m,(v+1,b))) : ss -- toggle view
-
-withMsg :: [String] -> ECommand -> ECommand
-withMsg m c = changeMsg m . c
-
-changeStOptions :: (Options -> Options) -> ECommand
-changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss
-
-noNeedForMsg :: ECommand
-noNeedForMsg = changeMsg [] -- everything's all right: no message
-
-candInfo :: [Exp] -> [String]
-candInfo ts = case length ts of
- 0 -> ["no acceptable alternative"]
- 1 -> ["just one acceptable alternative"]
- n -> [show n +++ "alternatives to select"]
-
--- * keep SState abstract from this on
-
--- ** editing commands
-
-action2command :: Action -> ECommand
-action2command act state = case act (stateSState state) of
- Ok s -> changeState s state
- Bad m -> changeMsg [m] state
-
-action2commandNext :: Action -> ECommand -- move to next meta after execution
-action2commandNext act = action2command (\s -> act s >>= goNextMetaIfCan)
-
-action2commandKeep :: Action -> ECommand -- keep old position after execution
-action2commandKeep act = action2command (\s -> keepPosition act s)
-
-undoCommand :: Int -> ECommand
-undoCommand n ss =
- let k = length ss in
- if k < n
- then changeMsg ["cannot go all the way back"] [last ss]
- else changeMsg ["successful undo"] (drop n ss)
-
-selectCand :: CGrammar -> Int -> ECommand
-selectCand gr i state = err (\m -> changeMsg [m] state) id $ do
- exp <- candsSState state !? i
- let s = stateSState state
- tree <- annotateInState gr exp s
- return $ case replaceSubTree tree s of
- Ok st' -> changeState st' state
- Bad s -> changeMsg [s] state
-
-refineByExps :: Bool -> CGrammar -> [Exp] -> ECommand
-refineByExps der gr trees = case trees of
- [t] -> action2commandNext (refineWithExpTC der gr t)
- _ -> changeCands trees
-
-refineByTrees :: Bool -> CGrammar -> [Tree] -> ECommand
-refineByTrees der gr trees = case trees of
- [t] -> action2commandNext (refineOrReplaceWithTree der gr t)
- _ -> changeCands $ map tree2exp trees
-
-replaceByTrees :: CGrammar -> [Exp] -> ECommand
-replaceByTrees gr trees = case trees of
- [t] -> action2commandNext (\s ->
- annotateExpInState gr t s >>= flip replaceSubTree s)
- _ -> changeCands trees
-
-replaceByEditCommand :: StateGrammar -> String -> ECommand
-replaceByEditCommand gr co =
- action2commandKeep $
- maybe return ($ gr) $
- lookupCustom customEditCommand (strCI co)
-
-replaceByTermCommand :: Bool -> StateGrammar -> String -> Tree -> ECommand ----
-replaceByTermCommand der gr co exp =
- let g = grammar gr in
- refineByTrees der g $ maybe [exp] (\f -> f gr exp) $
- lookupCustom customTermCommand (strCI co)
-
-possClipsSState :: StateGrammar -> SState -> [(Int,Clip)]
-possClipsSState gr s = filter poss $ zip [0..] (clipSState s)
- where
- poss = possibleTreeVal cgr st . snd
- st = stateSState s
- cgr = grammar gr
-
-getNumberedClip :: Int -> SState -> Err Clip
-getNumberedClip i s = if length cs > i then return (cs !! i)
- else Bad "not enough clips"
- where
- cs = clipSState s
diff --git a/src-3.0/GF/UseGrammar/Statistics.hs b/src-3.0/GF/UseGrammar/Statistics.hs
deleted file mode 100644
index 46e4fcc3b..000000000
--- a/src-3.0/GF/UseGrammar/Statistics.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Statistics
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/04 11:45:38 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.1 $
---
--- statistics on canonical grammar: amounts of generated code
--- AR 4\/9\/2005.
--- uses canonical grammar
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Statistics (prStatistics) where
-
-import GF.Infra.Modules
-import GF.Infra.Option
-import GF.Grammar.PrGrammar
-import GF.Canon.GFC
-import GF.Canon.MkGFC
-
-import GF.Data.Operations
-
-import Data.List (sortBy)
-
--- | the top level function
-prStatistics :: CanonGrammar -> String
-prStatistics can = unlines $ [
- show (length mods) ++ "\t\t modules",
- show chars ++ "\t\t gfc size",
- "",
- "Top 40 definitions"
- ] ++
- [show d ++ "\t\t " ++ f | (d,f) <- tops]
- where
- tops = take 40 $ reverse $ sortBy (\ (i,_) (j,_) -> compare i j) defs
- defs = [(length (prt (info2def j)), name m j) | (m,j) <- infos]
- infos = [(m,j) | (m,ModMod mo) <- mods, j <- tree2list (jments mo)]
- name m (f,_) = prt m ++ "." ++ prt f
- mods = modules can
- chars = length $ prCanon can
diff --git a/src-3.0/GF/UseGrammar/Tokenize.hs b/src-3.0/GF/UseGrammar/Tokenize.hs
deleted file mode 100644
index 9f1ab5449..000000000
--- a/src-3.0/GF/UseGrammar/Tokenize.hs
+++ /dev/null
@@ -1,222 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Tokenize
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/29 13:20:08 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
---
--- lexers = tokenizers, to prepare input for GF grammars. AR 4\/1\/2002.
--- an entry for each is included in 'Custom.customTokenizer'
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Tokenize ( tokWords,
- tokLits,
- tokVars,
- lexHaskell,
- lexHaskellLiteral,
- lexHaskellVar,
- lexText,
- lexTextVar,
- lexC2M, lexC2M',
- lexTextLiteral,
- lexIgnore,
- wordsLits
- ) where
-
-import GF.Data.Operations
----- import UseGrammar (isLiteral,identC)
-import GF.CF.CFIdent
-
-import Data.Char
-
--- lexers = tokenizers, to prepare input for GF grammars. AR 4/1/2002
--- an entry for each is included in Custom.customTokenizer
-
--- | just words
-tokWords :: String -> [CFTok]
-tokWords = map tS . words
-
-tokLits :: String -> [CFTok]
-tokLits = map mkCFTok . mergeStr . wordsLits where
- mergeStr ss = case ss of
- w@(c:cs):rest | elem c "\'\"" && c /= last w -> getStr [w] rest
- w :rest -> w : mergeStr rest
- [] -> []
- getStr v ss = case ss of
- w@(_:_):rest | elem (last w) "\'\"" -> (unwords (reverse (w:v))) : mergeStr rest
- w :rest -> getStr (w:v) rest
- [] -> reverse v
-
-tokVars :: String -> [CFTok]
-tokVars = map mkCFTokVar . wordsLits
-
-isFloat s = case s of
- c:cs | isDigit c -> isFloat cs
- '.':cs@(_:_) -> all isDigit cs
- _ -> False
-
-isString s = case s of
- c:cs@(_:_) -> (c == '\'' && d == '\'') || (c == '"' && d == '"') where d = last cs
- _ -> False
-
-
-mkCFTok :: String -> CFTok
-mkCFTok s = case s of
- '"' :cs@(_:_) | last cs == '"' -> tL $ init cs
- '\'':cs@(_:_) | last cs == '\'' -> tL $ init cs --- 's Gravenhage
- _:_ | isFloat s -> tF s
- _:_ | all isDigit s -> tI s
- _ -> tS s
-
-mkCFTokVar :: String -> CFTok
-mkCFTokVar s = case s of
- '?':_:_ -> tM s --- "?" --- compat with prCF
- 'x':'_':_ -> tV s
- 'x':[] -> tV s
- '$':xs@(_:_) -> if last s == '$' then tV (init xs) else tS s
- _ -> tS s
-
-mkTokVars :: (String -> [CFTok]) -> String -> [CFTok]
-mkTokVars tok = map tv . tok where
- tv (TS s) = mkCFTokVar s
- tv t = t
-
-mkLit :: String -> CFTok
-mkLit s
- | isFloat s = tF s
- | all isDigit s = tI s
- | otherwise = tL s
-
--- obsolete
-mkTL :: String -> CFTok
-mkTL s
- | isFloat s = tF s
- | all isDigit s = tI s
- | otherwise = tL ("'" ++ s ++ "'")
-
-
--- | Haskell lexer, usable for much code
-lexHaskell :: String -> [CFTok]
-lexHaskell ss = case lex ss of
- [(w@(_:_),ws)] -> tS w : lexHaskell ws
- _ -> []
-
--- | somewhat shaky text lexer
-lexText :: String -> [CFTok]
-lexText = uncap . lx where
-
- lx s = case s of
- '?':'?':cs -> tS "??" : lx cs
- p : cs | isMPunct p -> tS [p] : uncap (lx cs)
- p : cs | isPunct p -> tS [p] : lx cs
- s : cs | isSpace s -> lx cs
- _ : _ -> getWord s
- _ -> []
-
- getWord s = tS w : lx ws where (w,ws) = span isNotSpec s
- isMPunct c = elem c ".!?"
- isPunct c = elem c ",:;()\""
- isNotSpec c = not (isMPunct c || isPunct c || isSpace c)
- uncap (TS (c:cs) : ws) = tC (c:cs) : ws
- uncap s = s
-
--- | lexer for C--, a mini variant of C
-lexC2M :: String -> [CFTok]
-lexC2M = lexC2M' False
-
-lexC2M' :: Bool -> String -> [CFTok]
-lexC2M' isHigherOrder s = case s of
- '#':cs -> lexC $ dropWhile (/='\n') cs
- '/':'*':cs -> lexC $ dropComment cs
- c:cs | isSpace c -> lexC cs
- c:cs | isAlpha c -> getId s
- c:cs | isDigit c -> getLit s
- c:d:cs | isSymb [c,d] -> tS [c,d] : lexC cs
- c:cs | isSymb [c] -> tS [c] : lexC cs
- _ -> [] --- covers end of file and unknown characters
- where
- lexC = lexC2M' isHigherOrder
- getId s = mkT i : lexC cs where (i,cs) = span isIdChar s
- getLit s = tI i : lexC cs where (i,cs) = span isDigit s ---- Float!
- isIdChar c = isAlpha c || isDigit c || elem c "'_"
- isSymb = reservedAnsiCSymbol
- dropComment s = case s of
- '*':'/':cs -> cs
- _:cs -> dropComment cs
- _ -> []
- mkT i = if (isRes i) then (tS i) else
- if isHigherOrder then (tV i) else (tL ("'" ++ i ++ "'"))
- isRes = reservedAnsiC
-
-
-reservedAnsiCSymbol s = case lookupTree show s ansiCtree of
- Ok True -> True
- _ -> False
-
-reservedAnsiC s = case lookupTree show s ansiCtree of
- Ok False -> True
- _ -> False
-
--- | for an efficient lexer: precompile this!
-ansiCtree = buildTree $ [(s,True) | s <- reservedAnsiCSymbols] ++
- [(s,False) | s <- reservedAnsiCWords]
-
-reservedAnsiCSymbols = words $
- "<<= >>= << >> ++ -- == <= >= *= += -= %= /= &= ^= |= " ++
- "^ { } = , ; + * - ( ) < > & % ! ~"
-
-reservedAnsiCWords = words $
- "auto break case char const continue default " ++
- "do double else enum extern float for goto if int " ++
- "long register return short signed sizeof static struct switch typedef " ++
- "union unsigned void volatile while " ++
- "main printin putchar" --- these are not ansi-C
-
--- | turn unknown tokens into string literals; not recursively for literals 123, 'foo'
-unknown2string :: (String -> Bool) -> [CFTok] -> [CFTok]
-unknown2string isKnown = map mkOne where
- mkOne t@(TS s)
- | isKnown s = t
- | isFloat s = tF s
- | all isDigit s = tI s
- | otherwise = tL s
- mkOne t@(TC s) = if isKnown s then t else mkLit s
- mkOne t = t
-
-unknown2var :: (String -> Bool) -> [CFTok] -> [CFTok]
-unknown2var isKnown = map mkOne where
- mkOne t@(TS "??") = if isKnown "??" then t else tM "??"
- mkOne t@(TS s)
- | isKnown s = t
- | isFloat s = tF s
- | isString s = tL (init (tail s))
- | all isDigit s = tI s
- | otherwise = tV s
- mkOne t@(TC s) = if isKnown s then t else tV s
- mkOne t = t
-
-lexTextLiteral, lexHaskellLiteral, lexHaskellVar :: (String -> Bool) -> String -> [CFTok]
-
-lexTextLiteral isKnown = unknown2string (eitherUpper isKnown) . lexText
-lexHaskellLiteral isKnown = unknown2string isKnown . lexHaskell
-
-lexHaskellVar isKnown = unknown2var isKnown . lexHaskell
-lexTextVar isKnown = unknown2var (eitherUpper isKnown) . lexText
-
-
-eitherUpper isKnown w@(c:cs) = isKnown (toLower c : cs) || isKnown (toUpper c : cs)
-eitherUpper isKnown w = isKnown w
-
--- ignore unknown tokens (e.g. keyword spotting)
-
-lexIgnore :: (String -> Bool) -> [CFTok] -> [CFTok]
-lexIgnore isKnown = concatMap mkOne where
- mkOne t@(TS s)
- | isKnown s = [t]
- | otherwise = []
- mkOne t = [t]
-
diff --git a/src-3.0/GF/UseGrammar/Transfer.hs b/src-3.0/GF/UseGrammar/Transfer.hs
deleted file mode 100644
index 5d62f4385..000000000
--- a/src-3.0/GF/UseGrammar/Transfer.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Transfer
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:53 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.5 $
---
--- linearize, parse, etc, by transfer. AR 9\/10\/2003
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Transfer where
-
-import GF.Grammar.Grammar
-import GF.Grammar.Values
-import GF.Grammar.AbsCompute
-import qualified GF.Canon.GFC as GFC
-import GF.Grammar.LookAbs
-import GF.Grammar.MMacros
-import GF.Grammar.Macros
-import GF.Grammar.PrGrammar
-import GF.Grammar.TypeCheck
-
-import GF.Infra.Ident
-import GF.Data.Operations
-
-import qualified Transfer.Core.Abs as T
-
-import Control.Monad
-
-
--- transfer is done in T.Exp - we only need these conversions.
-
-exp2core :: Ident -> Exp -> T.Exp
-exp2core f = T.EApp (T.EVar (var f)) . exp2c where
- exp2c e = case e of
- App f a -> T.EApp (exp2c f) (exp2c a)
- Abs x b -> T.EAbs (T.PVVar (var x)) (exp2c b) ---- should be syntactic abstr
- Q _ c -> T.EVar (var c)
- QC _ c -> T.EVar (var c)
- K s -> T.EStr s
- EInt i -> T.EInteger $ toInteger i
- Meta m -> T.EMeta (T.TMeta (prt m)) ---- which meta symbol?
- Vr x -> T.EVar (var x) ---- should be syntactic var
-
- var x = T.CIdent $ prt x
-
-core2exp :: T.Exp -> Exp
-core2exp e = case e of
- T.EApp f a -> App (core2exp f) (core2exp a)
- T.EAbs (T.PVVar x) b -> Abs (var x) (core2exp b) ---- only from syntactic abstr
- T.EVar c -> Vr (var c) -- GF annotates to Q or QC
- T.EStr s -> K s
- T.EInteger i -> EInt $ fromInteger i
- T.EMeta _ -> uExp -- meta symbol 0, refreshed by GF
- where
- var :: T.CIdent -> Ident
- var (T.CIdent x) = zIdent x
-
-
-
--- The following are now obsolete (30/11/2005)
--- linearize, parse, etc, by transfer. AR 9/10/2003
-
-doTransfer :: GFC.CanonGrammar -> Ident -> Tree -> Err Tree
-doTransfer gr tra t = do
- cat <- liftM snd $ val2cat $ valTree t
- f <- lookupTransfer gr tra cat
- e <- compute gr $ App f $ tree2exp t
- annotate gr e
-
-useByTransfer :: (Tree -> Err a) -> GFC.CanonGrammar -> Ident -> (Tree -> Err a)
-useByTransfer lin gr tra t = doTransfer gr tra t >>= lin
-
-mkByTransfer :: (a -> Err [Tree]) -> GFC.CanonGrammar -> Ident -> (a -> Err [Tree])
-mkByTransfer parse gr tra s = parse s >>= mapM (doTransfer gr tra)
diff --git a/src-3.0/GF/UseGrammar/TreeSelections.hs b/src-3.0/GF/UseGrammar/TreeSelections.hs
deleted file mode 100644
index 9bf2711be..000000000
--- a/src-3.0/GF/UseGrammar/TreeSelections.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : TreeSelections
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- choose shallowest trees, and remove an overload resolution prefix
------------------------------------------------------------------------------
-
-module GF.UseGrammar.TreeSelections (
-
- getOverloadResults, smallestTrs, sizeTr, depthTr
-
- ) where
-
-import GF.Grammar.Abstract
-import GF.Grammar.Macros
-
-import GF.Data.Operations
-import GF.Data.Zipper
-import Data.List
-
--- AR 2/7/2007
--- The top-level function takes a set of trees (typically parses)
--- and returns the list of those trees that have the minimum size.
--- In addition, the overload prefix "ovrld123_", is removed
--- from each constructor in which it appears. This is used for
--- showing the library API constructors in a parsable grammar.
--- TODO: access the generic functions smallestTrs, sizeTr, depthTr from shell
-
-getOverloadResults :: [Tree] -> [Tree]
-getOverloadResults = smallestTrs sizeTr . map (mkOverload "ovrld")
-
--- NB: this does not always give the desired result, since
--- some genuine alternatives may be deeper: now we will exclude the
--- latter of
---
--- mkCl this_NP love_V2 (mkNP that_NP here_Adv)
--- mkCl this_NP (mkVP (mkVP love_V2 that_NP) here_Adv)
---
--- A perfect method would know the definitional equivalences of constructors.
---
--- Notice also that size is a better measure than depth, because:
--- 1. Global depth does not exclude the latter of
---
--- mkCl (mkNP he_Pron) love_V2 that_NP
--- mkCl (mkNP he_Pron) (mkVP love_V2 that_NP)
---
--- 2. Length is needed to exclude the latter of
---
--- mkS (mkCl (mkNP he_Pron) love_V2 that_NP)
--- mkS presentTense (mkCl (mkNP he_Pron) love_V2 that_NP)
---
-
-smallestTrs :: (Tr a -> Int) -> [Tr a] -> [Tr a]
-smallestTrs size ts = map fst $ filter ((==mx) . snd) tds where
- tds = [(t, size t) | t <- ts]
- mx = minimum $ map snd tds
-
-depthTr :: Tr a -> Int
-depthTr (Tr (_, ts)) = case ts of
- [] -> 1
- _ -> 1 + (maximum $ map depthTr ts)
-
-sizeTr :: Tr a -> Int
-sizeTr (Tr (_, ts)) = 1 + sum (map sizeTr ts)
-
--- remove from each constant a prefix starting with "pref", up to first "_"
--- example format: ovrld123_mkNP
-
-mkOverload :: String -> Tree -> Tree
-mkOverload pref = mapTr (changeAtom overAtom) where
- overAtom a = case a of
- AtC (m, IC f) | isPrefixOf pref f ->
- AtC (m, IC (tail (dropWhile (/='_') f)))
- _ -> a
diff --git a/src-3.0/GF/UseGrammar/Treebank.hs b/src-3.0/GF/UseGrammar/Treebank.hs
deleted file mode 100644
index 841a9c6dc..000000000
--- a/src-3.0/GF/UseGrammar/Treebank.hs
+++ /dev/null
@@ -1,251 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Treebank
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- Generate multilingual treebanks. AR 8\/2\/2006
---
--- (c) Aarne Ranta 2006 under GNU GPL
---
--- Purpose: to generate treebanks.
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Treebank (
- mkMultiTreebank,
- mkUniTreebank,
- multi2uniTreebank,
- uni2multiTreebank,
- testMultiTreebank,
- treesTreebank,
- getTreebank,
- getUniTreebank,
- readUniTreebanks,
- readMultiTreebank,
- lookupTreebank,
- assocsTreebank,
- isWordInTreebank,
- printAssoc,
- mkCompactTreebank
- ) where
-
-import GF.Compile.ShellState
-import GF.UseGrammar.Linear -- (linTree2string)
-import GF.UseGrammar.Custom
-import GF.UseGrammar.GetTree (string2tree)
-import GF.Grammar.TypeCheck (annotate)
-import GF.Canon.CMacros (noMark)
-import GF.Grammar.Grammar (Trm)
-import GF.Grammar.MMacros (exp2tree)
-import GF.Grammar.Macros (zIdent)
-import GF.Grammar.PrGrammar (prt_,prt)
-import GF.Grammar.Values (tree2exp)
-import GF.Data.Operations
-import GF.Infra.Option
-import GF.Infra.Ident (Ident)
-import GF.Infra.UseIO
-import qualified GF.Grammar.Abstract as A
-import qualified Data.Map as M
-import qualified Data.Set as S
-import qualified Data.List as L
-import Control.Monad (liftM)
-import System.FilePath
-
--- Generate a treebank with a multilingual grammar. AR 8/2/2006
--- (c) Aarne Ranta 2006 under GNU GPL
-
--- keys are trees; format: XML file
-type MultiTreebank = [(String,[(String,String)])] -- tree,lang,lin
-
--- keys are strings; format: string TAB tree TAB ... TAB tree
-type UniTreebank = Treebank -- M.Map String [String] -- string,tree
-
--- both formats can be read from both kinds of files
-readUniTreebanks :: FilePath -> IO [(Ident,UniTreebank)]
-readUniTreebanks file = do
- s <- readFileIf file
- return $ if isMultiTreebank s
- then multi2uniTreebank $ getTreebank $ lines s
- else
- let tb = getUniTreebank $ lines s
- in [(zIdent (dropExtension file),tb)]
-
-readMultiTreebank :: FilePath -> IO MultiTreebank
-readMultiTreebank file = do
- s <- readFileIf file
- return $ if isMultiTreebank s
- then getTreebank $ lines s
- else uni2multiTreebank (zIdent (dropExtension file)) $ getUniTreebank $ lines s
-
-isMultiTreebank :: String -> Bool
-isMultiTreebank s = take 10 s == "<treebank>"
-
-multi2uniTreebank :: MultiTreebank -> [(Ident,UniTreebank)]
-multi2uniTreebank mt@((_,lls):_) = [(zIdent la, mkTb la) | (la,_) <- lls] where
- mkTb la = M.fromListWith (++) [(s,[t]) | (t,lls) <- mt, (l,s) <- lls, l==la]
-multi2uniTreebank [] = []
-
-uni2multiTreebank :: Ident -> UniTreebank -> MultiTreebank
-uni2multiTreebank la tb =
- [(t,[(prt_ la, s)]) | (s,ts) <- assocsTreebank tb, t <- ts]
-
--- | the main functions
-
--- builds a treebank where trees are the keys, and writes a file (opt. XML)
-mkMultiTreebank :: Options -> ShellState -> String -> [A.Tree] -> Res
-mkMultiTreebank opts sh com trees
- | oElem (iOpt "compact") opts = mkCompactTreebank opts sh trees
-mkMultiTreebank opts sh com trees =
- putInXML opts "treebank" comm (concatMap mkItem tris) where
- mkItem(t,i)= putInXML opts "item" (cat i) (mkTree t ++ concatMap (mkLin t) langs)
--- mkItem(t,i)= putInXML opts "item" (cat i) (mkTree t >>mapM_ (mkLin t) langs)
- mkTree t = putInXML opts "tree" [] (puts $ showTree t)
- mkLin t lg = putInXML opts "lin" (lang lg) (puts $ linearize opts sh lg t)
-
- langs = [prt_ l | l <- allLanguages sh]
- comm = "" --- " command=" ++ show com +++ "abstract=" ++ show abstr
- abstr = "" --- "Abs" ----
- cat i = " number=" ++ show (show i) --- " cat=" ++ show "S" ----
- lang lg = " lang=" ++ show (prt_ (zIdent lg))
- tris = zip trees [1..]
-
--- builds a unilingual treebank where strings are the keys into an internal treebank
-
-mkUniTreebank :: Options -> ShellState -> Language -> [A.Tree] -> Treebank
-mkUniTreebank opts sh lg trees = M.fromListWith (++) [(lin t, [prt_ t]) | t <- trees]
- where
- lang = prt_ lg
- lin t = linearize opts sh lang t
-
--- reads a treebank and linearizes its trees again, printing all differences
-testMultiTreebank :: Options -> ShellState -> String -> Res
-testMultiTreebank opts sh = putInXML opts "testtreebank" [] .
- concatMap testOne .
- getTreebanks . lines
- where
- testOne (e,lang,str0) = do
- let tr = annot gr e
- let str = linearize opts sh lang tr
- if str == str0 then ret else putInXML opts "diff" [] $ concat [
- putInXML opts "tree" [] (puts $ showTree tr),
- putInXML opts "old" (" lang=" ++ show (prt_ (zIdent lang))) $ puts str0,
- putInXML opts "new" (" lang=" ++ show (prt_ (zIdent lang))) $ puts str
- ]
- gr = firstStateGrammar sh
-
--- writes all the trees of the treebank
-treesTreebank :: Options -> String -> [String]
-treesTreebank _ = terms . getTreebank . lines where
- terms ts = [t | (t,_) <- ts]
-
--- string vs. IO
-type Res = [String] -- IO ()
-puts :: String -> Res
-puts = return -- putStrLn
-ret = [] -- return ()
---
-
--- here strings are keys
-assocsTreebank :: UniTreebank -> [(String,[String])]
-assocsTreebank = M.assocs
-
-isWordInTreebank :: UniTreebank -> String -> Bool
-isWordInTreebank tb w = S.member w (S.fromList (concatMap words (M.keys tb)))
-
-printAssoc (s, ts) = s ++ concat ["\t" ++ t | t <- ts]
-
-getTreebanks :: [String] -> [(String,String,String)]
-getTreebanks = concatMap grps . getTreebank where
- grps (t,lls) = [(t,x,y) | (x,y) <- lls]
-
-getTreebank :: [String] -> MultiTreebank
-getTreebank ll = case ll of
- l:ls@(_:_:_) ->
- let (l1,l2) = getItem ls
- (tr,lins) = getTree l1
- lglins = getLins lins
- in (tr,lglins) : getTreebank l2
- _ -> []
- where
- getItem = span ((/="</item") . take 6)
-
- getTree (_:ss) =
- let (t1,t2) = span ((/="</tree") . take 6) ss in (last t1, drop 1 t2)
-
- getLins (beg:str:end:ss) = (getLang beg, str):getLins ss
- getLins _ = []
-
- getLang = takeWhile (/='"') . tail . dropWhile (/='"')
-
-getUniTreebank :: [String] -> UniTreebank
-getUniTreebank ls = M.fromListWith (++) [(s, ts) | s:ts <- map chop ls] where
- chop = chunks '\t'
-
-lookupTreebank :: Treebank -> String -> [String]
-lookupTreebank tb s = maybe [] id $ M.lookup s tb
-
-annot :: StateGrammar -> String -> A.Tree
-annot gr s = errVal (error "illegal tree") $ do
- let t = tree2exp $ string2tree gr s
- annotate (grammar gr) t
-
-putInXML :: Options -> String -> String -> Res -> Res
-putInXML opts tag attrs io =
- (ifXML $ puts $ tagXML $ tag ++ attrs) ++
- io ++
- (ifXML $ puts $ tagXML $ '/':tag)
- where
- ifXML c = if oElem showXML opts then c else []
-
-
-tagXML :: String -> String
-tagXML s = "<" ++ s ++ ">"
-
--- print the treebank in a compact format:
--- first a sorted list of all words, referrable by index
--- then the linearization of each tree, as sequences of word indices
--- this format is usable in embedded translation systems.
-
-mkCompactTreebank :: Options -> ShellState -> [A.Tree] -> [String]
-mkCompactTreebank opts sh = printCompactTreebank . mkJustMultiTreebank opts sh
-
-printCompactTreebank :: (MultiTreebank,[String]) -> [String]
-printCompactTreebank (tb,lgs) = (stat:langs:unwords ws : "\n" : linss) where
- ws = L.sort $ L.nub $ concat $ map (concatMap (words . snd) . snd) tb
-
- linss = map (unwords . pad) linss0
- linss0 = map (map (show . encode) . words) allExs
- allExs = concat [[snd (ls !! i) | (_,ls) <- tb] | i <- [0..length lgs - 1]]
- encode w = maybe undefined id $ M.lookup w wmap
- wmap = M.fromAscList $ zip ws [1..]
- stat = unwords $ map show [length ws, length lgs, length tb, smax]
- langs = unwords lgs
- smax = maximum $ map length linss0
- pad ws = ws ++ replicate (smax - length ws) "0"
-
--- [(String,[(String,String)])] -- tree,lang,lin
-mkJustMultiTreebank :: Options -> ShellState -> [A.Tree] -> (MultiTreebank,[String])
-mkJustMultiTreebank opts sh ts =
- ([(prt_ t, [(la, lin la t) | la <- langs]) | t <- ts],langs) where
- langs = map prt_ $ allLanguages sh
- lin = linearize opts sh
-
-
---- these handy functions are borrowed from EmbedAPI
-
-linearize opts mgr lang = lin where
- sgr = stateGrammarOfLangOpt False mgr zlang
- cgr = canModules mgr
- zlang = zIdent lang
- untok = customOrDefault (addOptions opts (stateOptions sgr)) useUntokenizer customUntokenizer sgr
- lin
- | oElem showRecord opts = err id id . liftM prt . linearizeNoMark cgr zlang
- | oElem tableLin opts =
- err id id . liftM (unlines . map untok . prLinTable True) . allLinTables True cgr zlang
- | oElem showAll opts =
- err id id . liftM (unlines . map untok . prLinTable False) . allLinTables False cgr zlang
-
- | otherwise = untok . linTree2string noMark cgr zlang
-
-showTree t = prt_ $ tree2exp t
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:43:45 +0000