From fc42d8ec3be8e398041d2f048f47b2d549b2a04f Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Thu, 22 May 2008 11:59:31 +0000 Subject: [PATCH] remove all files that aren't used in GF-3.0 --- src-3.0/GF/API.hs | 472 --- src-3.0/GF/API/BatchTranslate.hs | 43 - src-3.0/GF/API/GrammarToHaskell.hs | 271 -- src-3.0/GF/API/GrammarToTransfer.hs | 94 - src-3.0/GF/API/IOGrammar.hs | 96 - src-3.0/GF/API/MyParser.hs | 25 - src-3.0/GF/CF/CF.hs | 213 -- src-3.0/GF/CF/CFIdent.hs | 253 -- src-3.0/GF/CF/CFtoGrammar.hs | 62 - src-3.0/GF/CF/CanonToCF.hs | 214 -- src-3.0/GF/CF/ChartParser.hs | 206 -- src-3.0/GF/CF/EBNF.hs | 191 - src-3.0/GF/CF/PPrCF.hs | 102 - src-3.0/GF/CF/PrLBNF.hs | 150 - src-3.0/GF/CF/Profile.hs | 106 - src-3.0/GF/CFGM/AbsCFG.hs | 45 - src-3.0/GF/CFGM/CFG.cf | 36 - src-3.0/GF/CFGM/LexCFG.hs | 312 -- src-3.0/GF/CFGM/LexCFG.x | 135 - src-3.0/GF/CFGM/ParCFG.hs | 779 ---- src-3.0/GF/CFGM/ParCFG.y | 129 - src-3.0/GF/CFGM/PrintCFG.hs | 157 - src-3.0/GF/CFGM/PrintCFGrammar.hs | 113 - src-3.0/GF/Canon/AbsGFC.hs | 182 - src-3.0/GF/Canon/AbsToBNF.hs | 38 - src-3.0/GF/Canon/CMacros.hs | 334 -- src-3.0/GF/Canon/CanonToGFCC.hs | 45 - src-3.0/GF/Canon/CanonToGrammar.hs | 203 -- src-3.0/GF/Canon/GFC.cf | 170 - src-3.0/GF/Canon/GFC.hs | 104 - src-3.0/GF/Canon/GetGFC.hs | 78 - src-3.0/GF/Canon/LexGFC.hs | 346 -- src-3.0/GF/Canon/LexGFC.x | 132 - src-3.0/GF/Canon/Look.hs | 225 -- src-3.0/GF/Canon/MkGFC.hs | 237 -- src-3.0/GF/Canon/ParGFC.hs | 2142 ----------- src-3.0/GF/Canon/ParGFC.y | 385 -- src-3.0/GF/Canon/PrExp.hs | 46 - src-3.0/GF/Canon/PrintGFC.hs | 376 -- src-3.0/GF/Canon/Share.hs | 147 - src-3.0/GF/Canon/SkelGFC.hs | 217 -- src-3.0/GF/Canon/Subexpressions.hs | 170 - src-3.0/GF/Canon/TestGFC.hs | 58 - src-3.0/GF/Canon/Unlex.hs | 49 - src-3.0/GF/Canon/Unparametrize.hs | 63 - src-3.0/GF/Canon/log.txt | 20 - src-3.0/GF/Compile/CheckGrammar.hs | 1078 ------ src-3.0/GF/Compile/Compile.hs | 401 -- src-3.0/GF/Compile/Evaluate.hs | 477 --- src-3.0/GF/Compile/Flatten.hs | 92 - src-3.0/GF/Compile/GetGrammar.hs | 146 - src-3.0/GF/Compile/GrammarToCanon.hs | 293 -- src-3.0/GF/Compile/MkConcrete.hs | 154 - src-3.0/GF/Compile/MkResource.hs | 128 - src-3.0/GF/Compile/MkUnion.hs | 83 - src-3.0/GF/Compile/NewRename.hs | 294 -- src-3.0/GF/Compile/NoParse.hs | 49 - src-3.0/GF/Compile/Optimize.hs | 300 -- src-3.0/GF/Compile/PGrammar.hs | 77 - src-3.0/GF/Compile/PrOld.hs | 84 - src-3.0/GF/Compile/ShellState.hs | 568 --- src-3.0/GF/Compile/Wordlist.hs | 108 - src-3.0/GF/Conversion/GFC.hs | 157 - src-3.0/GF/Conversion/GFCtoSimple.hs | 175 - src-3.0/GF/Conversion/Haskell.hs | 71 - src-3.0/GF/Conversion/MCFGtoCFG.hs | 53 - src-3.0/GF/Conversion/MCFGtoFCFG.hs | 51 - src-3.0/GF/Conversion/Prolog.hs | 205 -- src-3.0/GF/Conversion/RemoveEpsilon.hs | 46 - src-3.0/GF/Conversion/RemoveErasing.hs | 113 - src-3.0/GF/Conversion/RemoveSingletons.hs | 82 - src-3.0/GF/Conversion/SimpleToFinite.hs | 178 - src-3.0/GF/Conversion/SimpleToMCFG.hs | 26 - .../GF/Conversion/SimpleToMCFG/Coercions.hs | 63 - src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs | 256 -- src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs | 129 - src-3.0/GF/Conversion/TypeGraph.hs | 58 - src-3.0/GF/Conversion/Types.hs | 146 - src-3.0/GF/Data/Compos.hs | 37 - src-3.0/GF/Data/Glue.hs | 30 - src-3.0/GF/Data/IncrementalDeduction.hs | 67 - src-3.0/GF/Data/Map.hs | 61 - src-3.0/GF/Data/OrdMap2.hs | 127 - src-3.0/GF/Data/OrdSet.hs | 120 - src-3.0/GF/Data/Parsers.hs | 196 - src-3.0/GF/Data/RedBlack.hs | 64 - src-3.0/GF/Data/SharedString.hs | 19 - src-3.0/GF/Data/Trie.hs | 129 - src-3.0/GF/Data/Trie2.hs | 120 - src-3.0/GF/Data/XML.hs | 57 - src-3.0/GF/Devel/AbsCompute.hs | 145 - src-3.0/GF/Devel/CheckGrammar.hs | 4 +- src-3.0/GF/Devel/CheckM.hs | 89 - src-3.0/GF/Devel/Compile/AbsGF.hs | 274 -- src-3.0/GF/Devel/Compile/CheckGrammar.hs | 1089 ------ src-3.0/GF/Devel/Compile/Compile.hs | 205 -- src-3.0/GF/Devel/Compile/ErrM.hs | 26 - src-3.0/GF/Devel/Compile/Extend.hs | 154 - src-3.0/GF/Devel/Compile/Factorize.hs | 251 -- src-3.0/GF/Devel/Compile/GF.cf | 326 -- src-3.0/GF/Devel/Compile/GFC.hs | 72 - src-3.0/GF/Devel/Compile/GFtoGFCC.hs | 542 --- src-3.0/GF/Devel/Compile/GetGrammar.hs | 56 - src-3.0/GF/Devel/Compile/LexGF.hs | 343 -- src-3.0/GF/Devel/Compile/Optimize.hs | 333 -- src-3.0/GF/Devel/Compile/ParGF.hs | 3210 ----------------- src-3.0/GF/Devel/Compile/PrintGF.hs | 481 --- src-3.0/GF/Devel/Compile/Refresh.hs | 118 - src-3.0/GF/Devel/Compile/Rename.hs | 239 -- src-3.0/GF/Devel/Compile/SourceToGF.hs | 679 ---- src-3.0/GF/Devel/GFC/Main.hs | 28 - src-3.0/GF/Devel/GFCCInterpreter.hs | 28 - src-3.0/GF/Devel/Grammar/AppPredefined.hs | 166 - src-3.0/GF/Devel/Grammar/Compute.hs | 380 -- src-3.0/GF/Devel/Grammar/Construct.hs | 221 -- src-3.0/GF/Devel/Grammar/GFtoSource.hs | 223 -- src-3.0/GF/Devel/Grammar/Grammar.hs | 172 - src-3.0/GF/Devel/Grammar/Lookup.hs | 168 - src-3.0/GF/Devel/Grammar/Macros.hs | 434 --- src-3.0/GF/Devel/Grammar/PatternMatch.hs | 146 - src-3.0/GF/Devel/Grammar/PrGF.hs | 246 -- src-3.0/GF/Devel/Infra/ReadFiles.hs | 348 -- src-3.0/GF/Devel/Options.hs | 269 -- src-3.0/GF/Devel/TC.hs | 1 - src-3.0/GF/Devel/TestGF3.hs | 9 - src-3.0/GF/Devel/TypeCheck.hs | 212 +- src-3.0/GF/Embed/EmbedAPI.hs | 114 - src-3.0/GF/Embed/EmbedCustom.hs | 113 - src-3.0/GF/Embed/EmbedParsing.hs | 65 - src-3.0/GF/Embed/TemplateApp.hs | 44 - src-3.0/GF/Formalism/CFG.hs | 50 - src-3.0/GF/Formalism/GCFG.hs | 47 - src-3.0/GF/Formalism/MCFG.hs | 58 - src-3.0/GF/Formalism/SimpleGFC.hs | 268 -- src-3.0/GF/Fudgets/ArchEdit.hs | 30 - src-3.0/GF/Fudgets/CommandF.hs | 134 - src-3.0/GF/Fudgets/EventF.hs | 51 - src-3.0/GF/Fudgets/FudgetOps.hs | 59 - src-3.0/GF/Fudgets/UnicodeF.hs | 37 - src-3.0/GF/GFCC/ComposOp.hs | 30 - src-3.0/GF/GFCC/LexGFCC.hs | 349 -- src-3.0/GF/GFCC/SkelGFCC.hs | 109 - src-3.0/GF/GFCC/TestGFCC.hs | 58 - src-3.0/GF/GFModes.hs | 112 - src-3.0/GF/Grammar/AbsCompute.hs | 145 - src-3.0/GF/Grammar/Compute.hs | 426 --- src-3.0/GF/Grammar/LookAbs.hs | 159 +- src-3.0/GF/Grammar/PrGrammar.hs | 39 +- src-3.0/GF/Grammar/SGrammar.hs | 169 - src-3.0/GF/Grammar/TC.hs | 299 -- src-3.0/GF/Grammar/TypeCheck.hs | 311 -- src-3.0/GF/IDE/IDECommands.hs | 95 - src-3.0/GF/Infra/Comments.hs | 43 - src-3.0/GF/Infra/Print.hs | 127 - src-3.0/GF/Infra/ReadFiles.hs | 362 -- src-3.0/GF/Infra/UseIO.hs | 330 -- src-3.0/GF/JavaScript/LexJS.hs | 337 -- src-3.0/GF/JavaScript/ParJS.hs | 1175 ------ src-3.0/GF/JavaScript/SkelJS.hs | 80 - src-3.0/GF/JavaScript/TestJS.hs | 58 - src-3.0/GF/OldParsing/CFGrammar.hs | 153 - src-3.0/GF/OldParsing/ConvertFiniteGFC.hs | 283 -- src-3.0/GF/OldParsing/ConvertFiniteSimple.hs | 121 - src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs | 34 - .../OldParsing/ConvertGFCtoMCFG/Coercions.hs | 71 - .../GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs | 281 -- src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs | 277 -- .../GF/OldParsing/ConvertGFCtoMCFG/Strict.hs | 189 - src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs | 122 - src-3.0/GF/OldParsing/ConvertGrammar.hs | 44 - src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs | 52 - src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs | 30 - .../ConvertSimpleToMCFG/Coercions.hs | 70 - .../OldParsing/ConvertSimpleToMCFG/Nondet.hs | 245 -- .../GF/OldParsing/ConvertSimpleToMCFG/Old.hs | 277 -- .../OldParsing/ConvertSimpleToMCFG/Strict.hs | 139 - src-3.0/GF/OldParsing/GCFG.hs | 43 - src-3.0/GF/OldParsing/GeneralChart.hs | 86 - src-3.0/GF/OldParsing/GrammarTypes.hs | 148 - src-3.0/GF/OldParsing/IncrementalChart.hs | 50 - src-3.0/GF/OldParsing/MCFGrammar.hs | 206 -- src-3.0/GF/OldParsing/ParseCF.hs | 82 - src-3.0/GF/OldParsing/ParseCFG.hs | 43 - src-3.0/GF/OldParsing/ParseCFG/General.hs | 83 - src-3.0/GF/OldParsing/ParseCFG/Incremental.hs | 142 - src-3.0/GF/OldParsing/ParseGFC.hs | 177 - src-3.0/GF/OldParsing/ParseMCFG.hs | 37 - src-3.0/GF/OldParsing/ParseMCFG/Basic.hs | 156 - src-3.0/GF/OldParsing/SimpleGFC.hs | 161 - src-3.0/GF/OldParsing/Utilities.hs | 188 - src-3.0/GF/Parsing/CF.hs | 66 - src-3.0/GF/Parsing/CFG.hs | 51 - src-3.0/GF/Parsing/CFG/General.hs | 103 - src-3.0/GF/Parsing/CFG/Incremental.hs | 150 - src-3.0/GF/Parsing/CFG/PInfo.hs | 98 - src-3.0/GF/Parsing/FCFG/Incremental.hs | 107 - src-3.0/GF/Parsing/GFC.hs | 208 -- src-3.0/GF/Parsing/MCFG.hs | 68 - src-3.0/GF/Parsing/MCFG/Active.hs | 318 -- src-3.0/GF/Parsing/MCFG/Active2.hs | 237 -- src-3.0/GF/Parsing/MCFG/FastActive.hs | 176 - src-3.0/GF/Parsing/MCFG/Incremental.hs | 178 - src-3.0/GF/Parsing/MCFG/Incremental2.hs | 157 - src-3.0/GF/Parsing/MCFG/Naive.hs | 142 - src-3.0/GF/Parsing/MCFG/PInfo.hs | 162 - src-3.0/GF/Parsing/MCFG/Range.hs | 206 -- src-3.0/GF/Parsing/MCFG/ViaCFG.hs | 186 - src-3.0/GF/Printing/PrintParser.hs | 83 - src-3.0/GF/Printing/PrintSimplifiedTerm.hs | 127 - src-3.0/GF/Probabilistic/Probabilistic.hs | 203 -- src-3.0/GF/Shell.hs | 591 --- src-3.0/GF/Shell/CommandL.hs | 198 - src-3.0/GF/Shell/Commands.hs | 568 --- src-3.0/GF/Shell/HelpFile.hs | 723 ---- src-3.0/GF/Shell/JGF.hs | 89 - src-3.0/GF/Shell/PShell.hs | 174 - src-3.0/GF/Shell/ShellCommands.hs | 246 -- src-3.0/GF/Shell/SubShell.hs | 66 - src-3.0/GF/Shell/TeachYourself.hs | 87 - src-3.0/GF/Source/SkelGF.hs | 381 -- src-3.0/GF/Source/TestGF.hs | 58 - src-3.0/GF/Speech/CFGToFiniteState.hs | 265 -- src-3.0/GF/Speech/FiniteState.hs | 329 -- src-3.0/GF/Speech/GrammarToVoiceXML.hs | 285 -- src-3.0/GF/Speech/Graph.hs | 178 - src-3.0/GF/Speech/PrFA.hs | 56 - src-3.0/GF/Speech/PrGSL.hs | 113 - src-3.0/GF/Speech/PrJSGF.hs | 145 - src-3.0/GF/Speech/PrRegExp.hs | 33 - src-3.0/GF/Speech/PrSLF.hs | 190 - src-3.0/GF/Speech/PrSRGS.hs | 153 - src-3.0/GF/Speech/PrSRGS_ABNF.hs | 147 - src-3.0/GF/Speech/RegExp.hs | 143 - src-3.0/GF/Speech/Relation.hs | 130 - src-3.0/GF/Speech/RelationQC.hs | 39 - src-3.0/GF/Speech/SISR.hs | 87 - src-3.0/GF/Speech/SRG.hs | 235 -- src-3.0/GF/Speech/TransformCFG.hs | 378 -- src-3.0/GF/System/ATKSpeechInput.hs | 137 - src-3.0/GF/System/Arch.hs | 90 - src-3.0/GF/System/ArchEdit.hs | 30 - src-3.0/GF/System/NoReadline.hs | 27 - src-3.0/GF/System/NoSignal.hs | 29 - src-3.0/GF/System/NoSpeechInput.hs | 28 - src-3.0/GF/System/Readline.hs | 27 - src-3.0/GF/System/Signal.hs | 27 - src-3.0/GF/System/SpeechInput.hs | 27 - src-3.0/GF/System/Tracing.hs | 73 - src-3.0/GF/System/UseReadline.hs | 25 - src-3.0/GF/System/UseSignal.hs | 58 - src-3.0/GF/Text/Arabic.hs | 63 - src-3.0/GF/Text/Devanagari.hs | 97 - src-3.0/GF/Text/Ethiopic.hs | 72 - src-3.0/GF/Text/ExtendedArabic.hs | 99 - src-3.0/GF/Text/ExtraDiacritics.hs | 37 - src-3.0/GF/Text/Greek.hs | 172 - src-3.0/GF/Text/Hebrew.hs | 53 - src-3.0/GF/Text/Hiragana.hs | 95 - src-3.0/GF/Text/LatinASupplement.hs | 69 - src-3.0/GF/Text/OCSCyrillic.hs | 47 - src-3.0/GF/Text/Russian.hs | 56 - src-3.0/GF/Text/Tamil.hs | 77 - src-3.0/GF/Text/Text.hs | 149 - src-3.0/GF/Text/Thai.hs | 368 -- src-3.0/GF/Text/Unicode.hs | 69 - src-3.0/GF/Translate/GFT.hs | 56 - src-3.0/GF/UseGrammar/Custom.hs | 494 --- src-3.0/GF/UseGrammar/Editing.hs | 434 --- src-3.0/GF/UseGrammar/Generate.hs | 116 - src-3.0/GF/UseGrammar/GetTree.hs | 74 - src-3.0/GF/UseGrammar/Information.hs | 162 - src-3.0/GF/UseGrammar/Linear.hs | 292 -- src-3.0/GF/UseGrammar/MatchTerm.hs | 50 - src-3.0/GF/UseGrammar/Morphology.hs | 140 - src-3.0/GF/UseGrammar/Paraphrases.hs | 70 - src-3.0/GF/UseGrammar/Parsing.hs | 177 - src-3.0/GF/UseGrammar/Randomized.hs | 66 - src-3.0/GF/UseGrammar/Session.hs | 181 - src-3.0/GF/UseGrammar/Statistics.hs | 44 - src-3.0/GF/UseGrammar/Tokenize.hs | 222 -- src-3.0/GF/UseGrammar/Transfer.hs | 79 - src-3.0/GF/UseGrammar/TreeSelections.hs | 77 - src-3.0/GF/UseGrammar/Treebank.hs | 251 -- src-3.0/GF/Visualization/Graphviz.hs | 116 - src-3.0/GF/Visualization/VisualizeGrammar.hs | 125 - src-3.0/GF/Visualization/VisualizeTree.hs | 58 - 286 files changed, 21 insertions(+), 53176 deletions(-) delete mode 100644 src-3.0/GF/API.hs delete mode 100644 src-3.0/GF/API/BatchTranslate.hs delete mode 100644 src-3.0/GF/API/GrammarToHaskell.hs delete mode 100644 src-3.0/GF/API/GrammarToTransfer.hs delete mode 100644 src-3.0/GF/API/IOGrammar.hs delete mode 100644 src-3.0/GF/API/MyParser.hs delete mode 100644 src-3.0/GF/CF/CF.hs delete mode 100644 src-3.0/GF/CF/CFIdent.hs delete mode 100644 src-3.0/GF/CF/CFtoGrammar.hs delete mode 100644 src-3.0/GF/CF/CanonToCF.hs delete mode 100644 src-3.0/GF/CF/ChartParser.hs delete mode 100644 src-3.0/GF/CF/EBNF.hs delete mode 100644 src-3.0/GF/CF/PPrCF.hs delete mode 100644 src-3.0/GF/CF/PrLBNF.hs delete mode 100644 src-3.0/GF/CF/Profile.hs delete mode 100644 src-3.0/GF/CFGM/AbsCFG.hs delete mode 100644 src-3.0/GF/CFGM/CFG.cf delete mode 100644 src-3.0/GF/CFGM/LexCFG.hs delete mode 100644 src-3.0/GF/CFGM/LexCFG.x delete mode 100644 src-3.0/GF/CFGM/ParCFG.hs delete mode 100644 src-3.0/GF/CFGM/ParCFG.y delete mode 100644 src-3.0/GF/CFGM/PrintCFG.hs delete mode 100644 src-3.0/GF/CFGM/PrintCFGrammar.hs delete mode 100644 src-3.0/GF/Canon/AbsGFC.hs delete mode 100644 src-3.0/GF/Canon/AbsToBNF.hs delete mode 100644 src-3.0/GF/Canon/CMacros.hs delete mode 100644 src-3.0/GF/Canon/CanonToGFCC.hs delete mode 100644 src-3.0/GF/Canon/CanonToGrammar.hs delete mode 100644 src-3.0/GF/Canon/GFC.cf delete mode 100644 src-3.0/GF/Canon/GFC.hs delete mode 100644 src-3.0/GF/Canon/GetGFC.hs delete mode 100644 src-3.0/GF/Canon/LexGFC.hs delete mode 100644 src-3.0/GF/Canon/LexGFC.x delete mode 100644 src-3.0/GF/Canon/Look.hs delete mode 100644 src-3.0/GF/Canon/MkGFC.hs delete mode 100644 src-3.0/GF/Canon/ParGFC.hs delete mode 100644 src-3.0/GF/Canon/ParGFC.y delete mode 100644 src-3.0/GF/Canon/PrExp.hs delete mode 100644 src-3.0/GF/Canon/PrintGFC.hs delete mode 100644 src-3.0/GF/Canon/Share.hs delete mode 100644 src-3.0/GF/Canon/SkelGFC.hs delete mode 100644 src-3.0/GF/Canon/Subexpressions.hs delete mode 100644 src-3.0/GF/Canon/TestGFC.hs delete mode 100644 src-3.0/GF/Canon/Unlex.hs delete mode 100644 src-3.0/GF/Canon/Unparametrize.hs delete mode 100644 src-3.0/GF/Canon/log.txt delete mode 100644 src-3.0/GF/Compile/CheckGrammar.hs delete mode 100644 src-3.0/GF/Compile/Compile.hs delete mode 100644 src-3.0/GF/Compile/Evaluate.hs delete mode 100644 src-3.0/GF/Compile/Flatten.hs delete mode 100644 src-3.0/GF/Compile/GetGrammar.hs delete mode 100644 src-3.0/GF/Compile/GrammarToCanon.hs delete mode 100644 src-3.0/GF/Compile/MkConcrete.hs delete mode 100644 src-3.0/GF/Compile/MkResource.hs delete mode 100644 src-3.0/GF/Compile/MkUnion.hs delete mode 100644 src-3.0/GF/Compile/NewRename.hs delete mode 100644 src-3.0/GF/Compile/NoParse.hs delete mode 100644 src-3.0/GF/Compile/Optimize.hs delete mode 100644 src-3.0/GF/Compile/PGrammar.hs delete mode 100644 src-3.0/GF/Compile/PrOld.hs delete mode 100644 src-3.0/GF/Compile/ShellState.hs delete mode 100644 src-3.0/GF/Compile/Wordlist.hs delete mode 100644 src-3.0/GF/Conversion/GFC.hs delete mode 100644 src-3.0/GF/Conversion/GFCtoSimple.hs delete mode 100644 src-3.0/GF/Conversion/Haskell.hs delete mode 100644 src-3.0/GF/Conversion/MCFGtoCFG.hs delete mode 100644 src-3.0/GF/Conversion/MCFGtoFCFG.hs delete mode 100644 src-3.0/GF/Conversion/Prolog.hs delete mode 100644 src-3.0/GF/Conversion/RemoveEpsilon.hs delete mode 100644 src-3.0/GF/Conversion/RemoveErasing.hs delete mode 100644 src-3.0/GF/Conversion/RemoveSingletons.hs delete mode 100644 src-3.0/GF/Conversion/SimpleToFinite.hs delete mode 100644 src-3.0/GF/Conversion/SimpleToMCFG.hs delete mode 100644 src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs delete mode 100644 src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs delete mode 100644 src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs delete mode 100644 src-3.0/GF/Conversion/TypeGraph.hs delete mode 100644 src-3.0/GF/Conversion/Types.hs delete mode 100644 src-3.0/GF/Data/Compos.hs delete mode 100644 src-3.0/GF/Data/Glue.hs delete mode 100644 src-3.0/GF/Data/IncrementalDeduction.hs delete mode 100644 src-3.0/GF/Data/Map.hs delete mode 100644 src-3.0/GF/Data/OrdMap2.hs delete mode 100644 src-3.0/GF/Data/OrdSet.hs delete mode 100644 src-3.0/GF/Data/Parsers.hs delete mode 100644 src-3.0/GF/Data/RedBlack.hs delete mode 100644 src-3.0/GF/Data/SharedString.hs delete mode 100644 src-3.0/GF/Data/Trie.hs delete mode 100644 src-3.0/GF/Data/Trie2.hs delete mode 100644 src-3.0/GF/Data/XML.hs delete mode 100644 src-3.0/GF/Devel/AbsCompute.hs delete mode 100644 src-3.0/GF/Devel/CheckM.hs delete mode 100644 src-3.0/GF/Devel/Compile/AbsGF.hs delete mode 100644 src-3.0/GF/Devel/Compile/CheckGrammar.hs delete mode 100644 src-3.0/GF/Devel/Compile/Compile.hs delete mode 100644 src-3.0/GF/Devel/Compile/ErrM.hs delete mode 100644 src-3.0/GF/Devel/Compile/Extend.hs delete mode 100644 src-3.0/GF/Devel/Compile/Factorize.hs delete mode 100644 src-3.0/GF/Devel/Compile/GF.cf delete mode 100644 src-3.0/GF/Devel/Compile/GFC.hs delete mode 100644 src-3.0/GF/Devel/Compile/GFtoGFCC.hs delete mode 100644 src-3.0/GF/Devel/Compile/GetGrammar.hs delete mode 100644 src-3.0/GF/Devel/Compile/LexGF.hs delete mode 100644 src-3.0/GF/Devel/Compile/Optimize.hs delete mode 100644 src-3.0/GF/Devel/Compile/ParGF.hs delete mode 100644 src-3.0/GF/Devel/Compile/PrintGF.hs delete mode 100644 src-3.0/GF/Devel/Compile/Refresh.hs delete mode 100644 src-3.0/GF/Devel/Compile/Rename.hs delete mode 100644 src-3.0/GF/Devel/Compile/SourceToGF.hs delete mode 100644 src-3.0/GF/Devel/GFC/Main.hs delete mode 100644 src-3.0/GF/Devel/GFCCInterpreter.hs delete mode 100644 src-3.0/GF/Devel/Grammar/AppPredefined.hs delete mode 100644 src-3.0/GF/Devel/Grammar/Compute.hs delete mode 100644 src-3.0/GF/Devel/Grammar/Construct.hs delete mode 100644 src-3.0/GF/Devel/Grammar/GFtoSource.hs delete mode 100644 src-3.0/GF/Devel/Grammar/Grammar.hs delete mode 100644 src-3.0/GF/Devel/Grammar/Lookup.hs delete mode 100644 src-3.0/GF/Devel/Grammar/Macros.hs delete mode 100644 src-3.0/GF/Devel/Grammar/PatternMatch.hs delete mode 100644 src-3.0/GF/Devel/Grammar/PrGF.hs delete mode 100644 src-3.0/GF/Devel/Infra/ReadFiles.hs delete mode 100644 src-3.0/GF/Devel/Options.hs delete mode 100644 src-3.0/GF/Devel/TestGF3.hs delete mode 100644 src-3.0/GF/Embed/EmbedAPI.hs delete mode 100644 src-3.0/GF/Embed/EmbedCustom.hs delete mode 100644 src-3.0/GF/Embed/EmbedParsing.hs delete mode 100644 src-3.0/GF/Embed/TemplateApp.hs delete mode 100644 src-3.0/GF/Formalism/CFG.hs delete mode 100644 src-3.0/GF/Formalism/GCFG.hs delete mode 100644 src-3.0/GF/Formalism/MCFG.hs delete mode 100644 src-3.0/GF/Formalism/SimpleGFC.hs delete mode 100644 src-3.0/GF/Fudgets/ArchEdit.hs delete mode 100644 src-3.0/GF/Fudgets/CommandF.hs delete mode 100644 src-3.0/GF/Fudgets/EventF.hs delete mode 100644 src-3.0/GF/Fudgets/FudgetOps.hs delete mode 100644 src-3.0/GF/Fudgets/UnicodeF.hs delete mode 100644 src-3.0/GF/GFCC/ComposOp.hs delete mode 100644 src-3.0/GF/GFCC/LexGFCC.hs delete mode 100644 src-3.0/GF/GFCC/SkelGFCC.hs delete mode 100644 src-3.0/GF/GFCC/TestGFCC.hs delete mode 100644 src-3.0/GF/GFModes.hs delete mode 100644 src-3.0/GF/Grammar/AbsCompute.hs delete mode 100644 src-3.0/GF/Grammar/Compute.hs delete mode 100644 src-3.0/GF/Grammar/SGrammar.hs delete mode 100644 src-3.0/GF/Grammar/TC.hs delete mode 100644 src-3.0/GF/Grammar/TypeCheck.hs delete mode 100644 src-3.0/GF/IDE/IDECommands.hs delete mode 100644 src-3.0/GF/Infra/Comments.hs delete mode 100644 src-3.0/GF/Infra/Print.hs delete mode 100644 src-3.0/GF/Infra/ReadFiles.hs delete mode 100644 src-3.0/GF/Infra/UseIO.hs delete mode 100644 src-3.0/GF/JavaScript/LexJS.hs delete mode 100644 src-3.0/GF/JavaScript/ParJS.hs delete mode 100644 src-3.0/GF/JavaScript/SkelJS.hs delete mode 100644 src-3.0/GF/JavaScript/TestJS.hs delete mode 100644 src-3.0/GF/OldParsing/CFGrammar.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertFiniteGFC.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertFiniteSimple.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertGrammar.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs delete mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs delete mode 100644 src-3.0/GF/OldParsing/GCFG.hs delete mode 100644 src-3.0/GF/OldParsing/GeneralChart.hs delete mode 100644 src-3.0/GF/OldParsing/GrammarTypes.hs delete mode 100644 src-3.0/GF/OldParsing/IncrementalChart.hs delete mode 100644 src-3.0/GF/OldParsing/MCFGrammar.hs delete mode 100644 src-3.0/GF/OldParsing/ParseCF.hs delete mode 100644 src-3.0/GF/OldParsing/ParseCFG.hs delete mode 100644 src-3.0/GF/OldParsing/ParseCFG/General.hs delete mode 100644 src-3.0/GF/OldParsing/ParseCFG/Incremental.hs delete mode 100644 src-3.0/GF/OldParsing/ParseGFC.hs delete mode 100644 src-3.0/GF/OldParsing/ParseMCFG.hs delete mode 100644 src-3.0/GF/OldParsing/ParseMCFG/Basic.hs delete mode 100644 src-3.0/GF/OldParsing/SimpleGFC.hs delete mode 100644 src-3.0/GF/OldParsing/Utilities.hs delete mode 100644 src-3.0/GF/Parsing/CF.hs delete mode 100644 src-3.0/GF/Parsing/CFG.hs delete mode 100644 src-3.0/GF/Parsing/CFG/General.hs delete mode 100644 src-3.0/GF/Parsing/CFG/Incremental.hs delete mode 100644 src-3.0/GF/Parsing/CFG/PInfo.hs delete mode 100644 src-3.0/GF/Parsing/FCFG/Incremental.hs delete mode 100644 src-3.0/GF/Parsing/GFC.hs delete mode 100644 src-3.0/GF/Parsing/MCFG.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/Active.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/Active2.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/FastActive.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/Incremental.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/Incremental2.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/Naive.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/PInfo.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/Range.hs delete mode 100644 src-3.0/GF/Parsing/MCFG/ViaCFG.hs delete mode 100644 src-3.0/GF/Printing/PrintParser.hs delete mode 100644 src-3.0/GF/Printing/PrintSimplifiedTerm.hs delete mode 100644 src-3.0/GF/Probabilistic/Probabilistic.hs delete mode 100644 src-3.0/GF/Shell.hs delete mode 100644 src-3.0/GF/Shell/CommandL.hs delete mode 100644 src-3.0/GF/Shell/Commands.hs delete mode 100644 src-3.0/GF/Shell/HelpFile.hs delete mode 100644 src-3.0/GF/Shell/JGF.hs delete mode 100644 src-3.0/GF/Shell/PShell.hs delete mode 100644 src-3.0/GF/Shell/ShellCommands.hs delete mode 100644 src-3.0/GF/Shell/SubShell.hs delete mode 100644 src-3.0/GF/Shell/TeachYourself.hs delete mode 100644 src-3.0/GF/Source/SkelGF.hs delete mode 100644 src-3.0/GF/Source/TestGF.hs delete mode 100644 src-3.0/GF/Speech/CFGToFiniteState.hs delete mode 100644 src-3.0/GF/Speech/FiniteState.hs delete mode 100644 src-3.0/GF/Speech/GrammarToVoiceXML.hs delete mode 100644 src-3.0/GF/Speech/Graph.hs delete mode 100644 src-3.0/GF/Speech/PrFA.hs delete mode 100644 src-3.0/GF/Speech/PrGSL.hs delete mode 100644 src-3.0/GF/Speech/PrJSGF.hs delete mode 100644 src-3.0/GF/Speech/PrRegExp.hs delete mode 100644 src-3.0/GF/Speech/PrSLF.hs delete mode 100644 src-3.0/GF/Speech/PrSRGS.hs delete mode 100644 src-3.0/GF/Speech/PrSRGS_ABNF.hs delete mode 100644 src-3.0/GF/Speech/RegExp.hs delete mode 100644 src-3.0/GF/Speech/Relation.hs delete mode 100644 src-3.0/GF/Speech/RelationQC.hs delete mode 100644 src-3.0/GF/Speech/SISR.hs delete mode 100644 src-3.0/GF/Speech/SRG.hs delete mode 100644 src-3.0/GF/Speech/TransformCFG.hs delete mode 100644 src-3.0/GF/System/ATKSpeechInput.hs delete mode 100644 src-3.0/GF/System/Arch.hs delete mode 100644 src-3.0/GF/System/ArchEdit.hs delete mode 100644 src-3.0/GF/System/NoReadline.hs delete mode 100644 src-3.0/GF/System/NoSignal.hs delete mode 100644 src-3.0/GF/System/NoSpeechInput.hs delete mode 100644 src-3.0/GF/System/Readline.hs delete mode 100644 src-3.0/GF/System/Signal.hs delete mode 100644 src-3.0/GF/System/SpeechInput.hs delete mode 100644 src-3.0/GF/System/Tracing.hs delete mode 100644 src-3.0/GF/System/UseReadline.hs delete mode 100644 src-3.0/GF/System/UseSignal.hs delete mode 100644 src-3.0/GF/Text/Arabic.hs delete mode 100644 src-3.0/GF/Text/Devanagari.hs delete mode 100644 src-3.0/GF/Text/Ethiopic.hs delete mode 100644 src-3.0/GF/Text/ExtendedArabic.hs delete mode 100644 src-3.0/GF/Text/ExtraDiacritics.hs delete mode 100644 src-3.0/GF/Text/Greek.hs delete mode 100644 src-3.0/GF/Text/Hebrew.hs delete mode 100644 src-3.0/GF/Text/Hiragana.hs delete mode 100644 src-3.0/GF/Text/LatinASupplement.hs delete mode 100644 src-3.0/GF/Text/OCSCyrillic.hs delete mode 100644 src-3.0/GF/Text/Russian.hs delete mode 100644 src-3.0/GF/Text/Tamil.hs delete mode 100644 src-3.0/GF/Text/Text.hs delete mode 100644 src-3.0/GF/Text/Thai.hs delete mode 100644 src-3.0/GF/Text/Unicode.hs delete mode 100644 src-3.0/GF/Translate/GFT.hs delete mode 100644 src-3.0/GF/UseGrammar/Custom.hs delete mode 100644 src-3.0/GF/UseGrammar/Editing.hs delete mode 100644 src-3.0/GF/UseGrammar/Generate.hs delete mode 100644 src-3.0/GF/UseGrammar/GetTree.hs delete mode 100644 src-3.0/GF/UseGrammar/Information.hs delete mode 100644 src-3.0/GF/UseGrammar/Linear.hs delete mode 100644 src-3.0/GF/UseGrammar/MatchTerm.hs delete mode 100644 src-3.0/GF/UseGrammar/Morphology.hs delete mode 100644 src-3.0/GF/UseGrammar/Paraphrases.hs delete mode 100644 src-3.0/GF/UseGrammar/Parsing.hs delete mode 100644 src-3.0/GF/UseGrammar/Randomized.hs delete mode 100644 src-3.0/GF/UseGrammar/Session.hs delete mode 100644 src-3.0/GF/UseGrammar/Statistics.hs delete mode 100644 src-3.0/GF/UseGrammar/Tokenize.hs delete mode 100644 src-3.0/GF/UseGrammar/Transfer.hs delete mode 100644 src-3.0/GF/UseGrammar/TreeSelections.hs delete mode 100644 src-3.0/GF/UseGrammar/Treebank.hs delete mode 100644 src-3.0/GF/Visualization/Graphviz.hs delete mode 100644 src-3.0/GF/Visualization/VisualizeGrammar.hs delete mode 100644 src-3.0/GF/Visualization/VisualizeTree.hs diff --git a/src-3.0/GF/API.hs b/src-3.0/GF/API.hs deleted file mode 100644 index b1deeddfc..000000000 --- a/src-3.0/GF/API.hs +++ /dev/null @@ -1,472 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : API --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:40 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.39 $ --- --- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001 ------------------------------------------------------------------------------ - -module GF.API where - -import qualified GF.Source.AbsGF as GF -import qualified GF.Canon.AbsGFC as A -import qualified GF.Compile.Rename as R -import GF.UseGrammar.GetTree -import GF.Canon.GFC ---- import qualified Values as V -import GF.Grammar.Values - ------import GetGrammar -import GF.Compile.Compile -import GF.API.IOGrammar -import GF.UseGrammar.Linear -import GF.UseGrammar.Parsing -import GF.UseGrammar.Morphology -import GF.CF.PPrCF -import GF.CF.CFIdent -import GF.Compile.PGrammar -import GF.UseGrammar.Randomized (mkRandomTree) - -import GF.Grammar.MMacros -import qualified GF.Grammar.Macros as M -import GF.Grammar.TypeCheck -import GF.Canon.CMacros -import GF.UseGrammar.Transfer -import qualified GF.UseGrammar.Generate as Gen - -import GF.Text.Text (untokWithXML) -import GF.Infra.Option -import GF.UseGrammar.Custom -import GF.Compile.ShellState -import GF.UseGrammar.Linear -import GF.Canon.GFC -import qualified GF.Grammar.Grammar as G -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import qualified GF.Grammar.Compute as Co -import qualified GF.Grammar.AbsCompute as AC -import qualified GF.Infra.Ident as I -import qualified GF.Compile.GrammarToCanon as GC -import qualified GF.Canon.CanonToGrammar as CG -import qualified GF.Canon.MkGFC as MC -import qualified GF.Embed.EmbedAPI as EA - -import GF.UseGrammar.Editing - -import GF.System.SpeechInput (recognizeSpeech) - -----import GrammarToXML - -----import GrammarToMGrammar as M - -import qualified Transfer.InterpreterAPI as T - -import GF.System.Arch (myStdGen) - -import GF.Text.UTF8 -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Data.Zipper - -import Data.List (nub) -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Control.Monad (liftM) -import System (system) -import System.FilePath - -type GFGrammar = StateGrammar -type GFCat = CFCat -type Ident = I.Ident ---- type Tree = V.Tree - --- these are enough for many simple applications - -file2grammar :: FilePath -> IO GFGrammar -file2grammar file = do - egr <- appIOE $ optFile2grammar (iOpts [beSilent]) file - err (\s -> putStrLn s >> return emptyStateGrammar) return egr - -linearize :: GFGrammar -> Tree -> String -linearize sgr = err id id . optLinearizeTree opts sgr where - opts = addOption firstLin $ stateOptions sgr - -term2tree :: GFGrammar -> G.Term -> Tree -term2tree gr = errVal uTree . annotate (grammar gr) . qualifTerm (absId gr) - -tree2term :: Tree -> G.Term -tree2term = tree2exp - -linearizeToAll :: [GFGrammar] -> Tree -> [String] -linearizeToAll grs t = [linearize gr t | gr <- grs] - -parse :: GFGrammar -> GFCat -> String -> [Tree] -parse sgr cat = errVal [] . parseString noOptions sgr cat - -parseAny :: [GFGrammar] -> GFCat -> String -> [Tree] -parseAny grs cat s = - concat [errVal [] (parseString (options [iOpt "trynextlang"]) gr cat s) | gr <- grs] - -translate :: GFGrammar -> GFGrammar -> GFCat -> String -> [String] -translate ig og cat = map (linearize og) . parse ig cat - -translateToAll :: GFGrammar -> [GFGrammar] -> GFCat -> String -> [String] -translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat - -translateFromAny :: [GFGrammar] -> GFGrammar -> GFCat -> String -> [String] -translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs] - -translateBetweenAll :: [GFGrammar] -> GFCat -> String -> [String] -translateBetweenAll grs cat = - concat . map (linearizeToAll grs) . parseAny grs cat - -homonyms :: GFGrammar -> GFCat -> Tree -> [Tree] -homonyms gr cat = nub . parse gr cat . linearize gr - -hasAmbiguousLin :: GFGrammar -> GFCat -> Tree -> Bool -hasAmbiguousLin gr cat t = case (homonyms gr cat t) of - _:_:_ -> True - _ -> False - -{- ---- --- returns printname if one exists; othewrise linearizes with metas -printOrLin :: GFGrammar -> Fun -> String -printOrLin gr = printOrLinearize (stateGrammarST gr) - --- reads a syntax file and writes it in a format wanted -transformGrammarFile :: Options -> FilePath -> IO String -transformGrammarFile opts file = do - sy <- useIOE GF.emptySyntax $ getSyntax opts file - return $ optPrintSyntax opts sy --} - -prIdent :: Ident -> String -prIdent = prt - -string2GFCat :: String -> String -> GFCat -string2GFCat = string2CFCat - --- then stg for customizable and internal use - -optFile2grammar :: Options -> FilePath -> IOE GFGrammar -optFile2grammar os f - | takeExtensions f == ".gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f - | otherwise = do - ((_,_,gr,_),_) <- compileModule os emptyShellState f - ioeErr $ grammar2stateGrammar os gr - -optFile2grammarE :: Options -> FilePath -> IOE GFGrammar -optFile2grammarE = optFile2grammar - - -string2treeInState :: GFGrammar -> String -> State -> Err Tree -string2treeInState gr s st = do - let metas = allMetas st - xs = map fst $ actBinds st - t0 <- pTerm s - let t = qualifTerm (absId gr) $ M.mkAbs xs $ refreshMetas metas $ t0 - annotateExpInState (grammar gr) t st - -string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term -string2srcTerm gr m s = do - t <- pTerm s - R.renameSourceTerm gr m t - -randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree] -randomTreesIO opts gr n = do - gen <- myStdGen mx - t <- err (\s -> putS s >> return []) - (return . singleton) $ - mkRandomTree gen mx g catfun - ts <- if n==1 then return [] else randomTreesIO opts gr (n-1) - return $ t ++ ts - where - catfun = case getOptVal opts withFun of - Just fun -> Right $ (absId gr, I.identC fun) - _ -> Left $ firstAbsCat opts gr - g = grammar gr - mx = optIntOrN opts flagDepth 41 - putS s = if oElem beSilent opts then return () else putStrLnFlush s - - -generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree] -generateTrees opts gr mt = - optIntOrAll opts flagNumber - [tr | t <- Gen.generateTrees opts gr' cat dpt mn mt, Ok tr <- [mkTr t]] - where - mkTr = annotate gr' . qualifTerm (absId gr) - gr' = grammar gr - cat = firstAbsCat opts gr - dpt = maybe 3 id $ getOptInt opts flagDepth - mn = getOptInt opts flagAlts - -speechGenerate :: Options -> String -> IO () -speechGenerate opts str = do - let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage - system ("flite" +++ "\" " ++ str ++ "\"") ---- system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan) - return () - -speechInput :: Options -> StateGrammar -> IO [String] -speechInput opt s = recognizeSpeech name language cfg cat number - where - opts = addOptions opt (stateOptions s) - name = cncId s - cfg = stateCFG s -- FIXME: use lang flag to select grammar - language = fromMaybe "en_UK" (getOptVal opts speechLanguage) - cat = prCFCat (firstCatOpts opts s) ++ "{}.s" - number = optIntOrN opts flagNumber 1 - -optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String -optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr - -optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String -optLinearizeTree opts0 gr t = case getOptVal opts transferFun of - Just m -> useByTransfer flin g (I.identC m) t - _ -> flin t - where - opts = addOptions opts0 (stateOptions gr) - flin = case getOptVal opts markLin of - Just mk - | mk == markOptXML -> lin markXML - | mk == markOptJava -> lin markXMLjgf - | mk == markOptStruct -> lin markBracket - | mk == markOptFocus -> lin markFocus - | mk == "metacat" -> lin metaCatMark - | otherwise -> lin noMark - _ -> lin noMark - - lin mk - | oElem showRecord opts = liftM prt . linearizeNoMark g c - | oElem tableLin opts = liftM (unlines . map untok . prLinTable True) . - allLinTables True g c - | oElem showFields opts = liftM (unlines . map untok) . - allLinBranchFields g c - | oElem showAll opts = liftM (unlines . map untok . prLinTable False) . - allLinTables False g c - | otherwise = return . unlines . map untok . optIntOrOne . linTree2strings mk g c - g = grammar gr - c = cncId gr - untok = if False ---- oElem (markLin markOptXML) opts - then untokWithXML unt - else unt - unt = customOrDefault opts useUntokenizer customUntokenizer gr - optIntOrOne = take $ optIntOrN opts flagNumber 1 - -{- ---- - untoksl . lin where - gr = concreteOf (stateGrammarST sgr) - lin -- options mutually exclusive, with priority: struct, rec, table, one - | oElem showStruct opts = markedLinString True gr . tree2loc - | oElem showRecord opts = err id prt . linTerm gr - | oElem tableLin opts = err id (concatMap prLinTable) . allLinsAsStrs gr - | oElem firstLin opts = unlines . map sstr . take 1 . allLinStrings gr - | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr - untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr - opts' = addOptions opts $ stateOptions sgr - untoksl = unlines . map untoks . lines --} - -{- -optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String -optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where - gr = concreteOf (stateGrammarST sgr) - ts = annotateTrm sgr ts0 - ms = map (renameTrm (lookupConcrete gr)) fs - lin -- options mutually exclusive, with priority: struct, rec, table - | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms - | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms - tkStrs = concat . map snd . concat . map snd - untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr - opts' = addOptions opts $ stateOptions sgr - untoksl = unlines . map untoks . lines --} - -optParseArg :: Options -> GFGrammar -> String -> [Tree] -optParseArg opts gr = err (const []) id . optParseArgErr opts gr - -optParseArgAny :: Options -> [GFGrammar] -> String -> [Tree] -optParseArgAny opts grs s = concat [pars gr s | gr <- grs] where - pars gr = optParseArg opts gr --- grammar options! - -optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree] -optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr - -optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String) -optParseArgErrMsg opts gr s = do - let cat = firstCatOpts opts gr - g = grammar gr - (ts,m) <- parseStringMsg opts gr cat s - ts' <- case getOptVal opts transferFun of - Just m -> mkByTransfer (const $ return ts) g (I.identC m) s - _ -> return ts - return (ts',m) - --- | analyses word by word -morphoAnalyse :: Options -> GFGrammar -> String -> String -morphoAnalyse opts gr - | oElem (iOpt "status") opts = morphoTextStatus mo - | oElem beShort opts = morphoTextShort mo - | otherwise = morphoText mo - where - mo = morpho gr - -isKnownWord :: GFGrammar -> String -> Bool -isKnownWord gr s = GF.UseGrammar.Morphology.isKnownWord (morpho gr) s - -unknownTokens :: GFGrammar -> [CFTok] -> [String] -unknownTokens gr ts = - [w | TC w <- ts, unk w && unk (uncap w)] ++ [w | TS w <- ts, unk w] - where - unk w = not $ GF.API.isKnownWord gr w - uncap (c:cs) = toLower c : cs - uncap s = s - - -{- -prExpXML :: StateGrammar -> Term -> [String] -prExpXML gr = prElementX . term2elemx (stateAbstract gr) - -prMultiGrammar :: Options -> ShellState -> String -prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts) --} --- access to customizable commands - -optPrintGrammar :: Options -> StateGrammar -> String -optPrintGrammar opts = pg opts - where - pg = customOrDefault opts grammarPrinter customGrammarPrinter - -optPrintMultiGrammar :: Options -> CanonGrammar -> String -optPrintMultiGrammar opts = encodeId . pmg opts . encode - where - pmg = customOrDefault opts grammarPrinter customMultiGrammarPrinter - -- if -utf8 was given, convert from language specific codings - encode = if oElem useUTF8 opts then mapModules moduleToUTF8 else id - -- if -utf8id was given, convert non-literals to UTF8 - encodeId = if oElem useUTF8id opts then nonLiteralsToUTF8 else id - moduleToUTF8 m = - m{ jments = mapTree (onSnd (mapInfoTerms code)) (jments m), - flags = setFlag "coding" "utf8" (flags m) } - where code = onTokens (anyCodingToUTF8 (moduleOpts m)) - moduleOpts = Opts . okError . mapM CG.redFlag . flags - -optPrintSyntax :: Options -> GF.Grammar -> String -optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter - -optPrintTree :: Options -> GFGrammar -> Tree -> String -optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter - --- | look for string command (-filter=x) -optStringCommand :: Options -> GFGrammar -> String -> String -optStringCommand opts g = - optIntOrAll opts flagLength . - customOrDefault opts filterString customStringCommand g - -optTermCommand :: Options -> GFGrammar -> Tree -> [Tree] -optTermCommand opts st = - optIntOrAll opts flagNumber . - customOrDefault opts termCommand customTermCommand st - - --- wraps term in a function and optionally computes the result - -wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree -wrapByFun opts gr f t = - if oElem doCompute opts - then err (const t) id $ AC.computeAbsTerm (grammar gr) t' >>= annotate g - else err (const t) id $ annotate g t' - where - t' = qualifTerm (absId gr) $ M.appCons f [tree2exp t] - g = grammar gr - -applyTransfer :: Options -> GFGrammar -> [(Ident,T.Env)] -> - (Maybe Ident,Ident) -> Tree -> Err [Tree] -applyTransfer opts gr trs (mm,f) t = mapM (annotate g) ts' - where - ts' = map (qualifTerm (absId gr)) $ trans tr f $ tree2exp t - g = grammar gr - tr = case mm of - Just m -> maybe empty id $ lookup m trs - _ -> ifNull empty (snd . head) trs - -- FIXME: if the returned value is a list, - -- return a list of trees - trans :: T.Env -> Ident -> Exp -> [Exp] - trans tr f = (:[]) . core2exp . T.evaluateExp tr . exp2core f - empty = T.builtin - -{- -optTransfer :: Options -> StateGrammar -> G.Term -> G.Term -optTransfer opts g = case getOptVal opts transferFun of - Just f -> wrapByFun (addOption doCompute opts) g (M.zIdent f) - _ -> id --} - -optTokenizerResult :: Options -> GFGrammar -> String -> [[CFTok]] -optTokenizerResult opts gr = customOrDefault opts useTokenizer customTokenizer gr - -optTokenizer :: Options -> GFGrammar -> String -> String -optTokenizer opts gr = show . optTokenizerResult opts gr - --- performs UTF8 if the language does not have flag coding=utf8; replaces name*U - --- | convert a Unicode string into a UTF8 encoded string -optEncodeUTF8 :: GFGrammar -> String -> String -optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of - Just "utf8" -> id - _ -> encodeUTF8 - --- | convert a UTF8 encoded string into a Unicode string -optDecodeUTF8 :: GFGrammar -> String -> String -optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of - Just "utf8" -> decodeUTF8 - _ -> id - --- | convert a string encoded with some coding given by the coding flag to UTF8 -anyCodingToUTF8 :: Options -> String -> String -anyCodingToUTF8 opts = - encodeUTF8 . customOrDefault opts uniCoding customUniCoding - - --- | Convert all text not inside double quotes to UTF8 -nonLiteralsToUTF8 :: String -> String -nonLiteralsToUTF8 "" = "" -nonLiteralsToUTF8 ('"':cs) = '"' : l ++ nonLiteralsToUTF8 rs - where - (l,rs) = takeStringLit cs - -- | Split off an initial string ended by double quotes - takeStringLit :: String -> (String,String) - takeStringLit "" = ("","") - takeStringLit ('"':cs) = (['"'],cs) - takeStringLit ('\\':'"':cs) = ('\\':'"':xs,ys) - where (xs,ys) = takeStringLit cs - takeStringLit (c:cs) = (c:xs,ys) - where (xs,ys) = takeStringLit cs -nonLiteralsToUTF8 (c:cs) = encodeUTF8 [c] ++ nonLiteralsToUTF8 cs - - -printParadigm :: G.Term -> String -printParadigm term = - if hasTable term then - (unlines . map prBranch . branches . head . tables) term - else - prt term - where - tables t = case t of - G.R rs -> concatMap (tables . snd . snd) rs - G.T _ cs -> [cs] - _ -> [] - hasTable t = not $ null $ tables t - branches cs = [(p:ps,s) | - (p,t) <- cs, - let ts = tables t, - (ps,s) <- if null ts then [([],t)] - else concatMap branches ts - ] - prBranch (ps,s) = unwords (map prt ps ++ [prt s]) diff --git a/src-3.0/GF/API/BatchTranslate.hs b/src-3.0/GF/API/BatchTranslate.hs deleted file mode 100644 index c1b124526..000000000 --- a/src-3.0/GF/API/BatchTranslate.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : BatchTranslate --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- translate OCL, etc, files in batch mode ------------------------------------------------------------------------------ - -module GF.API.BatchTranslate (translate) where - -import GF.API -import GetMyTree (file2tree) - -translate :: FilePath -> FilePath -> IO () -translate fgr txt = do - gr <- file2grammar fgr - s <- file2tree txt - putStrLn $ linearize gr s - - -{- headers for model-specific grammars: - -abstract userDefined = oclLibrary ** { - ---# -path=.:abstract:prelude:English:ExtraEng -concrete userDefinedEng of userDefined = oclLibraryEng ** open externalOperEng in { - ---# -path=.:abstract:prelude:German:ExtraGer -concrete userDefinedGer of userDefined = oclLibraryGer ** open -externalOperGer in { - - -It seems we should add open - - ParadigmsX, ResourceExtX, PredicationX - --} diff --git a/src-3.0/GF/API/GrammarToHaskell.hs b/src-3.0/GF/API/GrammarToHaskell.hs deleted file mode 100644 index c57cfed42..000000000 --- a/src-3.0/GF/API/GrammarToHaskell.hs +++ /dev/null @@ -1,271 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToHaskell --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 12:39:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- to write a GF abstract grammar into a Haskell module with translations from --- data objects into GF trees. Example: GSyntax for Agda. --- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ------------------------------------------------------------------------------ - -module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where - -import qualified GF.Canon.GFC as GFC -import GF.Grammar.Macros - -import GF.Infra.Modules -import GF.Data.Operations - -import Data.List (isPrefixOf, find, intersperse) -import Data.Maybe (fromMaybe) - --- | the main function -grammar2haskell :: GFC.CanonGrammar -> String -grammar2haskell gr = foldr (++++) [] $ - haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr'] - where gr' = hSkeleton gr - -grammar2haskellGADT :: GFC.CanonGrammar -> String -grammar2haskellGADT gr = foldr (++++) [] $ - ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ - haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT gr', - gfinstances gr', fginstances gr'] - where gr' = hSkeleton gr - --- | by this you can prefix all identifiers with stg; the default is 'G' -gId :: OIdent -> OIdent -gId i = 'G':i - -haskPreamble = - [ - "module GSyntax where", - "", - "import GF.Infra.Ident", - "import GF.Grammar.Grammar", - "import GF.Grammar.PrGrammar", - "import GF.Grammar.Macros", - "import GF.Data.Compos", - "import GF.Data.Operations", - "", - "import Control.Applicative (pure,(<*>))", - "import Data.Traversable (traverse)", - "----------------------------------------------------", - "-- automatic translation from GF to Haskell", - "----------------------------------------------------", - "", - "class Gf a where gf :: a -> Trm", - "class Fg a where fg :: Trm -> a", - "", - predefInst "GString" "String" "K s", - "", - predefInst "GInt" "Integer" "EInt s", - "", - predefInst "GFloat" "Double" "EFloat s", - "", - "----------------------------------------------------", - "-- below this line machine-generated", - "----------------------------------------------------", - "" - ] - -predefInst gtyp typ patt = - "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ - "instance Gf" +++ gtyp +++ "where" ++++ - " gf (" ++ gtyp +++ "s) =" +++ patt +++++ - "instance Fg" +++ gtyp +++ "where" ++++ - " fg t =" ++++ - " case termForm t of" ++++ - " Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++ - " _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)" - -type OIdent = String - -type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] - -datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String -datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd -gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g -fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g - -hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String -hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String - -hDatatype ("Cn",_) = "" --- -hDatatype (cat,[]) = "" -hDatatype (cat,rules) | isListCat (cat,rules) = - "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" - +++ "deriving Show" -hDatatype (cat,rules) = - "data" +++ gId cat +++ "=" ++ - (if length rules == 1 then "" else "\n ") +++ - foldr1 (\x y -> x ++ "\n |" +++ y) - [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++ - " deriving Show" - --- GADT version of data types -datatypesGADT :: (String,HSkeleton) -> String -datatypesGADT (_,skel) = - unlines (concatMap hCatTypeGADT skel) - +++++ - "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel) - -hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] -hCatTypeGADT (cat,rules) - = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", - "data"+++gId cat++"_"] - -hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT (cat, rules) - | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] - | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] - where t = "Tree" +++ gId cat ++ "_" - - -----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance m (cat,[]) = "" -hInstance m (cat,rules) - | isListCat (cat,rules) = - "instance Gf" +++ gId cat +++ "where" ++++ - " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" - +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ - " gf (" ++ gId cat +++ "(x:xs)) = " - ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] --- no show for GADTs --- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" - | otherwise = - "instance Gf" +++ gId cat +++ "where" ++ - (if length rules == 1 then "" else "\n") +++ - foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules] - where - ec = elemCat cat - baseVars = mkVars (baseSize (cat,rules)) - mkInst f xx = let xx' = mkVars (length xx) in "gf " ++ - (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ - "=" +++ mkRHS f xx' - mkVars n = ["x" ++ show i | i <- [1..n]] - mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" - - -----fInstance m ("Cn",_) = "" --- -fInstance m (cat,[]) = "" -fInstance m (cat,rules) = - "instance Fg" +++ gId cat +++ "where" ++++ - " fg t =" ++++ - " case termForm t of" ++++ - foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ prt t)" - where - mkInst f xx = - " Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++ - "[" ++ prTList "," xx' ++ "])" +++ - "->" +++ mkRHS f xx' - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] - mkRHS f vars - | isListCat (cat,rules) = - if "Base" `isPrefixOf` f then - gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" - else - let (i,t) = (init vars,last vars) - in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ - gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) - | otherwise = - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- vars] - -composInstance :: (String,HSkeleton) -> String -composInstance (_,skel) = unlines $ - ["instance Compos Tree where", - " compos f t = case t of"] - ++ map (" "++) (concatMap prComposCat skel - ++ if not allRecursive then ["_ -> pure t"] else []) - where - prComposCat c@(cat, fs) - | isListCat c = [gId cat +++ "xs" +++ "->" - +++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"] - | otherwise = concatMap (prComposFun cat) fs - prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String] - prComposFun cat c@(fun,args) - | any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs] - | otherwise = [] - where vars = ["x" ++ show n | n <- [1..length args]] - rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args) - where prRec var typ - | not (isTreeType typ) = "<*>" +++ "pure" +++ var - | otherwise = "<*>" +++ "f" +++ var - allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs] - isTreeType cat = cat `elem` (map fst skel ++ builtin) - isList cat = case filter ((==cat) . fst) skel of - [] -> error $ "Unknown cat " ++ show cat - x:_ -> isListCat x - builtin = ["GString", "GInt", "GFloat"] - -showInstanceGADT :: (String,HSkeleton) -> String -showInstanceGADT (_,skel) = unlines $ - ["instance Show (Tree c) where", - " showsPrec n t = case t of"] - ++ map (" "++) (concatMap prShowCat skel) - ++ [" where opar n = if n > 0 then showChar '(' else id", - " cpar n = if n > 0 then showChar ')' else id"] - where - prShowCat c@(cat, fs) - | isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"] - | otherwise = map (prShowFun cat) fs - prShowFun :: OIdent -> (OIdent,[OIdent]) -> String - prShowFun cat (fun,args) - | null vars = gId fun +++ "->" +++ "showString" +++ show fun - | otherwise = gId fun +++ unwords vars +++ "->" - +++ "opar n . showString" +++ show fun - +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars] - +++ ". cpar n" - where vars = ["x" ++ show n | n <- [1..length args]] - -hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton) -hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where - collectR rr hh = - case rr of - (fun,typ):rs -> case catSkeleton typ of - Ok (cats,cat) -> - collectR rs (updateSkeleton (symid (snd cat)) hh (fun, - map (symid . snd) cats)) - _ -> collectR rs hh - _ -> hh - cats = [symid cat | (cat,GFC.AbsCat _ _) <- defs] - rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs] - - defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m] - name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m] - -updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton -updateSkeleton cat skel rule = - case skel of - (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr - (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule - _ -> error $ cat ++ ": updating empty skeleton with" +++ show rule - -isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules - --- | Gets the element category of a list category. -elemCat :: OIdent -> OIdent -elemCat = drop 4 - -isBaseFun :: OIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` f - -isConsFun :: OIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` f - -baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src-3.0/GF/API/GrammarToTransfer.hs b/src-3.0/GF/API/GrammarToTransfer.hs deleted file mode 100644 index 658c15184..000000000 --- a/src-3.0/GF/API/GrammarToTransfer.hs +++ /dev/null @@ -1,94 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToTransfer --- Maintainer : Björn Bringert --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 12:39:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- Creates a data type definition in the transfer language --- for an abstract module. ------------------------------------------------------------------------------ - -module GF.API.GrammarToTransfer (grammar2transfer) where - -import qualified GF.Canon.GFC as GFC -import qualified GF.Grammar.Abstract as A -import GF.Grammar.Macros - -import GF.Infra.Modules -import GF.Data.Operations - -import Transfer.Syntax.Abs as S -import Transfer.Syntax.Print - - --- | the main function -grammar2transfer :: GFC.CanonGrammar -> String -grammar2transfer gr = printTree $ S.Module imports decls - where - cat = S.Ident "Cat" -- FIXME - tree = S.Ident "Tree" -- FIXME - defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m] - -- get category name and context - cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs] - -- get function name and type - funs = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs] - name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m] - imports = [Import (S.Ident "prelude")] - decls = [cats2cat cat tree cats, funs2tree cat tree funs] ++ instances tree - - --- | Create a declaration of the type of categories given a list --- of category names and their contexts. -cats2cat :: S.Ident -- ^ the name of the Cat type - -> S.Ident -- ^ the name of the Tree type - -> [(A.Ident,A.Context)] -> Decl -cats2cat cat tree = S.DataDecl cat S.EType . map (uncurry catCons) - where - catCons i c = S.ConsDecl (id2id i) (catConsType c) - catConsType = foldr pi (S.EVar cat) - pi (i,x) t = mkPi (id2pv i) (addTree tree $ term2exp x) t - -funs2tree :: S.Ident -- ^ the name of the Cat type - -> S.Ident -- ^ the name of the Tree type - -> [(A.Ident,A.Type)] -> Decl -funs2tree cat tree = - S.DataDecl tree (S.EPiNoVar (S.EVar cat) S.EType) . map (uncurry funCons) - where - funCons i t = S.ConsDecl (id2id i) (addTree tree $ term2exp t) - -term2exp :: A.Term -> S.Exp -term2exp t = case t of - A.Vr i -> S.EVar (id2id i) - A.App t1 t2 -> S.EApp (term2exp t1) (term2exp t2) - A.Abs i t1 -> S.EAbs (id2pv i) (term2exp t1) - A.Prod i t1 t2 -> mkPi (id2pv i) (term2exp t1) (term2exp t2) - A.Q m i -> S.EVar (id2id i) - _ -> error $ "term2exp: can't handle " ++ show t - -mkPi :: S.VarOrWild -> S.Exp -> S.Exp -> S.Exp -mkPi VWild t e = S.EPiNoVar t e -mkPi v t e = S.EPi v t e - -id2id :: A.Ident -> S.Ident -id2id = S.Ident . symid - -id2pv :: A.Ident -> S.VarOrWild -id2pv i = case symid i of - "h_" -> S.VWild -- FIXME: hacky? - x -> S.VVar (S.Ident x) - --- FIXME: I think this is not general enoguh. -addTree :: S.Ident -> S.Exp -> S.Exp -addTree tree x = case x of - S.EPi i t e -> S.EPi i (addTree tree t) (addTree tree e) - S.EPiNoVar t e -> S.EPiNoVar (addTree tree t) (addTree tree e) - e -> S.EApp (S.EVar tree) e - -instances :: S.Ident -> [S.Decl] -instances tree = [DeriveDecl (S.Ident "Eq") tree, - DeriveDecl (S.Ident "Compos") tree] diff --git a/src-3.0/GF/API/IOGrammar.hs b/src-3.0/GF/API/IOGrammar.hs deleted file mode 100644 index bd7fc5648..000000000 --- a/src-3.0/GF/API/IOGrammar.hs +++ /dev/null @@ -1,96 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : IOGrammar --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:40 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.20 $ --- --- for reading grammars and terms from strings and files ------------------------------------------------------------------------------ - -module GF.API.IOGrammar (shellStateFromFiles, - getShellStateFromFiles) where - -import GF.Grammar.Abstract -import qualified GF.Canon.GFC as GFC -import GF.Compile.PGrammar -import GF.Grammar.TypeCheck -import GF.Compile.Compile -import GF.Compile.ShellState -import GF.Compile.NoParse -import GF.Probabilistic.Probabilistic -import GF.UseGrammar.Treebank - -import GF.Infra.Modules -import GF.Infra.ReadFiles (isOldFile) -import GF.Infra.Option -import GF.Data.Operations -import GF.Infra.UseIO -import GF.System.Arch - -import qualified Transfer.InterpreterAPI as T - -import Control.Monad (liftM) -import System.FilePath - --- | a heuristic way of renaming constants is used -string2absTerm :: String -> String -> Term -string2absTerm m = renameTermIn m . pTrm - -renameTermIn :: String -> Term -> Term -renameTermIn m = refreshMetas [] . rename [] where - rename vs t = case t of - Abs x b -> Abs x (rename (x:vs) b) - Vr c -> if elem c vs then t else Q (zIdent m) c - App f a -> App (rename vs f) (rename vs a) - _ -> t - -string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree -string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt - -----string2paramList :: ConcreteST -> String -> [Term] ----string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList - -shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState -shellStateFromFiles opts st file = do - ign <- ioeIO $ getNoparseFromFile opts file - let top = identC $ justModuleName file - sh <- case takeExtensions file of - ".trc" -> do - env <- ioeIO $ T.loadFile file - return $ addTransfer (top,env) st - ".gfcm" -> do - cenv <- compileOne opts (compileEnvShSt st []) file - ioeErr $ updateShellState opts ign Nothing st cenv - s | elem s [".cf",".ebnf"] -> do - let osb = addOptions (options []) opts - grts <- compileModule osb st file - ioeErr $ updateShellState opts ign Nothing st grts - s | oElem (iOpt "treebank") opts -> do - tbs <- ioeIO $ readUniTreebanks file - return $ addTreebanks tbs st - _ -> do - b <- ioeIO $ isOldFile file - let opts' = if b then (addOption showOld opts) else opts - - let osb = if oElem showOld opts' - then addOptions (options []) opts' -- for old no emit - else addOptions (options [emitCode]) opts' - grts <- compileModule osb st file - let mtop = if oElem showOld opts' then Nothing else Just top - ioeErr $ updateShellState opts' ign mtop st grts - if (isSetFlag opts probFile || oElem (iOpt "prob") opts) - then do - probs <- ioeIO $ getProbsFromFile opts file - let lang = maybe top id $ concrete sh --- to work with cf, too - ioeErr $ addProbs (lang,probs) sh - else return sh - -getShellStateFromFiles :: Options -> FilePath -> IO ShellState -getShellStateFromFiles os = - useIOE emptyShellState . - shellStateFromFiles os emptyShellState diff --git a/src-3.0/GF/API/MyParser.hs b/src-3.0/GF/API/MyParser.hs deleted file mode 100644 index c926fe865..000000000 --- a/src-3.0/GF/API/MyParser.hs +++ /dev/null @@ -1,25 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MyParser --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- template to define your own parser (obsolete?) ------------------------------------------------------------------------------ - -module GF.API.MyParser (myParser) where - -import GF.Compile.ShellState -import GF.CF.CFIdent -import GF.CF.CF -import GF.Data.Operations - --- type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String) - -myParser :: StateGrammar -> CFCat -> CFParser -myParser gr cat toks = ([],"Would you like to add your own parser?") diff --git a/src-3.0/GF/CF/CF.hs b/src-3.0/GF/CF/CF.hs deleted file mode 100644 index 9233e905a..000000000 --- a/src-3.0/GF/CF/CF.hs +++ /dev/null @@ -1,213 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- context-free grammars. AR 15\/12\/1999 -- 30\/3\/2000 -- 2\/6\/2001 -- 3\/12\/2001 ------------------------------------------------------------------------------ - -module GF.CF.CF (-- * Types - CF(..), CFRule, CFRuleGroup, - CFItem(..), CFTree(..), CFPredef, CFParser, - RegExp(..), CFWord, - -- * Functions - cfParseResults, - -- ** to construct CF grammars - emptyCF, emptyCFPredef, rules2CF, groupCFRules, - -- ** to construct rules - atomCFRule, atomCFTerm, atomRegExp, altsCFTerm, - -- ** to construct trees - atomCFTree, buildCFTree, - -- ** to decide whether a token matches a terminal item - matchCFTerm, satRegExp, - -- ** to analyse a CF grammar - catsOfCF, rulesOfCF, ruleGroupsOfCF, rulesForCFCat, - valCatCF, valItemsCF, valFunCF, - startCat, predefOfCF, appCFPredef, valCFItem, - cfTokens, wordsOfRegExp, forCFItem, - isCircularCF, predefRules - ) where - -import GF.Data.Operations -import GF.Data.Str -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.CF.CFIdent -import Data.List (nub,nubBy) -import Data.Char (isUpper, isLower, toUpper, toLower) - --- CF grammar data types - --- | abstract type CF. --- Invariant: each category has all its rules grouped with it --- also: the list is never empty (the category is just missing then) -newtype CF = CF ([CFRuleGroup], CFPredef) -type CFRule = (CFFun, (CFCat, [CFItem])) -type CFRuleGroup = (CFCat,[CFRule]) - --- | CFPredef is a hack for variable symbols and literals; normally = @const []@ -data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show) - -newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show) - --- | recognize literals, variables, etc -type CFPredef = CFTok -> [(CFCat, CFFun)] - --- | Wadler style + return information -type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String) - -cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree] -cfParseResults rs = [b | (b,[]) <- fst rs] - --- | terminals are regular expressions on words; to be completed to full regexp -data RegExp = - RegAlts [CFWord] -- ^ list of alternative words - | RegSpec CFTok -- ^ special token - deriving (Eq, Ord, Show) - -type CFWord = String - --- the above types should be kept abstract, and the following functions used - --- to construct CF grammars - -emptyCF :: CF -emptyCF = CF ([], emptyCFPredef) - -emptyCFPredef :: CFPredef -emptyCFPredef = const [] - -rules2CF :: [CFRule] -> CF -rules2CF rs = CF (groupCFRules rs, emptyCFPredef) - -groupCFRules :: [CFRule] -> [(CFCat,[CFRule])] -groupCFRules = foldr ins [] where - ins rule crs = case crs of - (c,r) : rs | compatCF c cat -> (c,rule:r) : rs - cr : rs -> cr : ins rule rs - _ -> [(cat,[rule])] - where - cat = valCatCF rule - --- to construct rules - --- | make a rule from a single token without constituents -atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule -atomCFRule c f s = (f, (c, [atomCFTerm s])) - --- | usual terminal -atomCFTerm :: CFTok -> CFItem -atomCFTerm = CFTerm . atomRegExp - -atomRegExp :: CFTok -> RegExp -atomRegExp t = case t of - TS s -> RegAlts [s] - _ -> RegSpec t - --- | terminal consisting of alternatives -altsCFTerm :: [String] -> CFItem -altsCFTerm = CFTerm . RegAlts - - --- to construct trees - --- | make a tree without constituents -atomCFTree :: CFCat -> CFFun -> CFTree -atomCFTree c f = buildCFTree c f [] - --- | make a tree with constituents. -buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree -buildCFTree c f trees = CFTree (f,(c,trees)) - -{- ---- -cfMeta0 :: CFTree -cfMeta0 = atomCFTree uCFCat metaCFFun - --- used in happy -litCFTree :: String -> CFTree --- Maybe CFTree -litCFTree s = maybe cfMeta0 id $ do - (c,f) <- getCFLiteral s - return $ buildCFTree c f [] --} - --- to decide whether a token matches a terminal item - -matchCFTerm :: CFItem -> CFTok -> Bool -matchCFTerm (CFTerm t) s = satRegExp t s -matchCFTerm _ _ = False - -satRegExp :: RegExp -> CFTok -> Bool -satRegExp r t = case (r,t) of - (RegAlts tt, TS s) -> elem s tt - (RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s] - (RegSpec x, _) -> t == x --- - _ -> False - where - caseUpperOrLower s = case s of - c:cs | isUpper c -> [s, toLower c : cs] - c:cs | isLower c -> [s, toUpper c : cs] - _ -> [s] - --- to analyse a CF grammar - -catsOfCF :: CF -> [CFCat] -catsOfCF (CF (rr,_)) = map fst rr - -rulesOfCF :: CF -> [CFRule] -rulesOfCF (CF (rr,_)) = concatMap snd rr - -ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])] -ruleGroupsOfCF (CF (rr,_)) = rr - -rulesForCFCat :: CF -> CFCat -> [CFRule] -rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr - -valCatCF :: CFRule -> CFCat -valCatCF (_,(c,_)) = c - -valItemsCF :: CFRule -> [CFItem] -valItemsCF (_,(_,i)) = i - -valFunCF :: CFRule -> CFFun -valFunCF (f,(_,_)) = f - -startCat :: CF -> CFCat -startCat (CF (rr,_)) = fst (head rr) --- hardly useful - -predefOfCF :: CF -> CFPredef -predefOfCF (CF (_,f)) = f - -appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)] -appCFPredef = ($) . predefOfCF - -valCFItem :: CFItem -> Either RegExp CFCat -valCFItem (CFTerm r) = Left r -valCFItem (CFNonterm nt) = Right nt - -cfTokens :: CF -> [CFWord] -cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf, - CFTerm i <- valItemsCF r] - -wordsOfRegExp :: RegExp -> [CFWord] -wordsOfRegExp (RegAlts tt) = tt -wordsOfRegExp _ = [] - -forCFItem :: CFTok -> CFRule -> Bool -forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a -forCFItem _ _ = False - --- | we should make a test of circular chains, too -isCircularCF :: CFRule -> Bool -isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c -isCircularCF _ = False - --- | coercion to the older predef cf type -predefRules :: CFPredef -> CFTok -> [CFRule] -predefRules pre s = [atomCFRule c f s | (c,f) <- pre s] - diff --git a/src-3.0/GF/CF/CFIdent.hs b/src-3.0/GF/CF/CFIdent.hs deleted file mode 100644 index 02ee482c0..000000000 --- a/src-3.0/GF/CF/CFIdent.hs +++ /dev/null @@ -1,253 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CFIdent --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:40 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- symbols (categories, functions) for context-free grammars. ------------------------------------------------------------------------------ - -module GF.CF.CFIdent (-- * Tokens and categories - CFTok(..), CFCat(..), - tS, tC, tL, tI, tF, tV, tM, tInt, - prCFTok, - -- * Function names and profiles - CFFun(..), Profile, - wordsCFTok, - -- * CF Functions - mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun, - intCFFun, floatCFFun, dummyCFFun, - cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun, - -- * CF Categories - mkCIdent, ident2CFCat, labels2CFCat, string2CFCat, - catVarCF, cat2CFCat, cfCatString, cfCatInt,cfCatFloat, - moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat, - -- * CF Tokens - string2CFTok, str2cftoks, - -- * Comparisons - compatToks, compatTok, compatCFFun, compatCF, - wordsLits - ) where - -import GF.Data.Operations -import GF.Canon.GFC -import GF.Infra.Ident -import GF.Grammar.Values (cPredefAbs) -import GF.Canon.AbsGFC -import GF.Grammar.Macros (ident2label) -import GF.Grammar.PrGrammar -import GF.Data.Str -import Data.Char (toLower, toUpper, isSpace) -import Data.List (intersperse) - --- | this type should be abstract -data CFTok = - TS String -- ^ normal strings - | TC String -- ^ strings that are ambiguous between upper or lower case - | TL String -- ^ string literals - | TI Integer -- ^ integer literals - | TF Double -- ^ float literals - | TV Ident -- ^ variables - | TM Int String -- ^ metavariables; the integer identifies it - deriving (Eq, Ord, Show) - --- | this type should be abstract -newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show) - -tS :: String -> CFTok -tC :: String -> CFTok -tL :: String -> CFTok -tI :: String -> CFTok -tF :: String -> CFTok -tV :: String -> CFTok -tM :: String -> CFTok - -tS = TS -tC = TC -tL = TL -tI = TI . read -tF = TF . read -tV = TV . identC -tM = TM 0 - -tInt :: Integer -> CFTok -tInt = TI - -prCFTok :: CFTok -> String -prCFTok t = case t of - TS s -> s - TC s -> s - TL s -> s - TI i -> show i - TF i -> show i - TV x -> prt x - TM i m -> m --- "?" --- m - --- | to build trees: the Atom contains a GF function, @Cn | Meta | Vr | Literal@ -newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show) --- - - - - - - - - - - - - - - - - - - - - ^^^ added by peb, 21/5-04 - -type Profile = [([[Int]],[Int])] - -wordsCFTok :: CFTok -> [String] -wordsCFTok t = case t of - TC (c:cs) -> [c':cs | c' <- [toUpper c, toLower c]] - _ -> [prCFTok t] - --- the following functions should be used instead of constructors - --- to construct CF functions - -mkCFFun :: Atom -> CFFun -mkCFFun t = CFFun (t,[]) - -varCFFun :: Ident -> CFFun -varCFFun = mkCFFun . AV - -consCFFun :: CIdent -> CFFun -consCFFun = mkCFFun . AC - --- | standard way of making cf fun -string2CFFun :: String -> String -> CFFun -string2CFFun m c = consCFFun $ mkCIdent m c - -stringCFFun :: String -> CFFun -stringCFFun = mkCFFun . AS - -intCFFun :: Integer -> CFFun -intCFFun = mkCFFun . AI - -floatCFFun :: Double -> CFFun -floatCFFun = mkCFFun . AF - --- | used in lexer-by-need rules -dummyCFFun :: CFFun -dummyCFFun = varCFFun $ identC "_" - -cfFun2String :: CFFun -> String -cfFun2String (CFFun (f,_)) = prt f - -cfFun2Ident :: CFFun -> Ident -cfFun2Ident (CFFun (f,_)) = identC $ prt_ f --- - -cfFun2Profile :: CFFun -> Profile -cfFun2Profile (CFFun (_,p)) = p - -{- ---- -strPro2cfFun :: String -> Profile -> CFFun -strPro2cfFun str p = (CFFun (AC (Ident str), p)) --} - -metaCFFun :: CFFun -metaCFFun = mkCFFun $ AM 0 - --- to construct CF categories - --- | belongs elsewhere -mkCIdent :: String -> String -> CIdent -mkCIdent m c = CIQ (identC m) (identC c) - -ident2CFCat :: CIdent -> Ident -> CFCat -ident2CFCat mc d = CFCat (mc, L d) - -labels2CFCat :: CIdent -> [Label] -> CFCat -labels2CFCat mc d = CFCat (mc, L (identC (concat (intersperse "." (map prt d))))) ---- - --- | standard way of making cf cat: label s -string2CFCat :: String -> String -> CFCat -string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s") - -idents2CFCat :: Ident -> Ident -> CFCat -idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s") - -catVarCF :: CFCat -catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ---- - -cat2CFCat :: (Ident,Ident) -> CFCat -cat2CFCat = uncurry idents2CFCat - --- | literals -cfCatString :: CFCat -cfCatString = string2CFCat (prt cPredefAbs) "String" - -cfCatInt, cfCatFloat :: CFCat -cfCatInt = string2CFCat (prt cPredefAbs) "Int" -cfCatFloat = string2CFCat (prt cPredefAbs) "Float" - - - -{- ---- -uCFCat :: CFCat -uCFCat = cat2CFCat uCat --} - -moduleOfCFCat :: CFCat -> Ident -moduleOfCFCat (CFCat (CIQ m _, _)) = m - --- | the opposite direction -cfCat2Cat :: CFCat -> (Ident,Ident) -cfCat2Cat (CFCat (CIQ m c,_)) = (m,c) - -cfCat2Ident :: CFCat -> Ident -cfCat2Ident = snd . cfCat2Cat - -lexCFCat :: CFCat -> CFCat -lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*") - --- to construct CF tokens - -string2CFTok :: String -> CFTok -string2CFTok = tS - -str2cftoks :: Str -> [CFTok] -str2cftoks = map tS . wordsLits . sstr - --- decide if two token lists look the same (in parser postprocessing) - -compatToks :: [CFTok] -> [CFTok] -> Bool -compatToks ts us = and [compatTok t u | (t,u) <- zip ts us] - -compatTok :: CFTok -> CFTok -> Bool -compatTok (TM _ _) _ = True --- hack because metas are renamed -compatTok _ (TM _ _) = True -compatTok t u = any (`elem` (alts t)) (alts u) where - alts u = case u of - TC (c:s) -> [toLower c : s, toUpper c : s] - TL s -> [s, prQuotedString s] - _ -> [prCFTok u] - --- | decide if two CFFuns have the same function head (profiles may differ) -compatCFFun :: CFFun -> CFFun -> Bool -compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g - --- | decide whether two categories match --- the modifiers can be from different modules, but on the same extension --- path, so there is no clash, and they can be safely ignored --- -compatCF :: CFCat -> CFCat -> Bool -----compatCF = (==) -compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l' - --- | Like 'words', but does not split on whitespace inside --- double quotes.wordsLits :: String -> [String] --- Also treats escaped quotes in quotes (AR 21/12/2005) by breaks --- instead of break -wordsLits [] = [] -wordsLits (c:cs) | isSpace c = wordsLits (dropWhile isSpace cs) - | isQuote c - = let (l,rs) = breaks (==c) cs - rs' = drop 1 rs - in ([c]++l++[c]):wordsLits rs' - | otherwise = let (w,rs) = break isSpaceQ cs - in (c:w):wordsLits rs - where - breaks c cs = case break c cs of - (l@(_:_),d:rs) | last l == '\\' -> - let (r,ts) = breaks c rs in (l++[d]++r, ts) - v -> v - isQuote c = elem c "\"'" - isSpaceQ c = isSpace c ---- || isQuote c diff --git a/src-3.0/GF/CF/CFtoGrammar.hs b/src-3.0/GF/CF/CFtoGrammar.hs deleted file mode 100644 index ebf97db91..000000000 --- a/src-3.0/GF/CF/CFtoGrammar.hs +++ /dev/null @@ -1,62 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CFtoGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- 26\/1\/2000 -- 18\/4 -- 24\/3\/2004 ------------------------------------------------------------------------------ - -module GF.CF.CFtoGrammar (cf2grammar) where - -import GF.Infra.Ident -import GF.Grammar.Grammar -import qualified GF.Source.AbsGF as A -import qualified GF.Source.GrammarToSource as S -import GF.Grammar.Macros - -import GF.CF.CF -import GF.CF.CFIdent -import GF.CF.PPrCF - -import GF.Data.Operations - -import Data.List (nub) -import Data.Char (isSpace) - -cf2grammar :: CF -> [A.TopDef] -cf2grammar cf = concatMap S.trAnyDef (abs ++ conc) where - rules = rulesOfCF cf - abs = cats ++ funs - conc = lintypes ++ lins - cats = [(cat, AbsCat (yes []) (yes [])) | - cat <- nub (concat (map cf2cat rules))] ----notPredef cat - lintypes = [(cat, CncCat (yes defLinType) nope nope) | (cat,AbsCat _ _) <- cats] - (funs,lins) = unzip (map cf2rule rules) - -cf2cat :: CFRule -> [Ident] -cf2cat (_,(cat, items)) = map cfCat2Ident $ cat : [c | CFNonterm c <- items] - -cf2rule :: CFRule -> ((Ident,Info),(Ident,Info)) -cf2rule (fun, (cat, items)) = (def,ldef) where - f = cfFun2Ident fun - def = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope) - args0 = zip (map (identV "x") [0..]) items - args = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0] - args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0] - ldef = (f, CncFun - Nothing - (yes (mkAbs (map fst args) - (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) - nope) - mkIt (v, CFNonterm _) = P (Vr v) theLinLabel - mkIt (_, CFTerm (RegAlts [a])) = K a - mkIt _ = K "" --- regexp not recognized in input CF ; use EBNF for this - foldconcat [] = K "" - foldconcat tt = foldr1 C tt - diff --git a/src-3.0/GF/CF/CanonToCF.hs b/src-3.0/GF/CF/CanonToCF.hs deleted file mode 100644 index 80ce2e79d..000000000 --- a/src-3.0/GF/CF/CanonToCF.hs +++ /dev/null @@ -1,214 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CanonToCF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.15 $ --- --- AR 27\/1\/2000 -- 3\/12\/2001 -- 8\/6\/2003 ------------------------------------------------------------------------------ - -module GF.CF.CanonToCF (canon2cf) where - -import GF.System.Tracing -- peb 8/6-04 - -import GF.Data.Operations -import GF.Infra.Option -import GF.Infra.Ident -import GF.Canon.AbsGFC -import GF.Grammar.LookAbs (allBindCatsOf) -import GF.Canon.GFC -import GF.Grammar.Values (isPredefCat,cPredefAbs) -import GF.Grammar.PrGrammar -import GF.Canon.CMacros -import qualified GF.Infra.Modules as M -import GF.CF.CF -import GF.CF.CFIdent -import GF.UseGrammar.Morphology -import GF.Data.Trie2 -import Data.List (nub,partition) -import Control.Monad - --- | The main function: for a given cnc module 'm', build the CF grammar with all the --- rules coming from modules that 'm' extends. The categories are qualified by --- the abstract module name 'a' that 'm' is of. --- The ign argument tells what rules not to generate a parser for. -canon2cf :: Options -> (Ident -> Bool) -> CanonGrammar -> Ident -> Err CF -canon2cf opts ign gr c = tracePrt "#size of CF" (err id (show.length.rulesOfCF)) $ do -- peb 8/6-04 - let ms = M.allExtends gr c - a <- M.abstractOfConcrete gr c - let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms] - let mms = [(a, tree2list (M.jments m)) | m <- cncs] - cnc <- liftM M.jments $ M.lookupModMod gr c - rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts ign cnc)) mms - let bindcats = map snd $ allBindCatsOf gr - let rules = filter (not . isCircularCF) rules0 ---- temporarily here - let grules = groupCFRules rules - let predef = mkCFPredef opts bindcats grules - return $ CF predef - -cnc2cfCond :: Options -> (Ident -> Bool) -> BinTree Ident Info -> - Ident -> [(Ident,Info)] -> Err [CFRule] -cnc2cfCond opts ign cnc m gr = - liftM concat $ - mapM lin2cf [(m,fun,cat,args,lin) | - (fun, CncFun cat args lin _) <- gr, notign fun, is fun] - where - is f = isInBinTree f cnc - notign = not . ign - -type IFun = Ident -type ICat = CIdent - --- | all CF rules corresponding to a linearization rule -lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule] -lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do - let rhss0 = allLinBranches lin -- :: [([Label], Term)] - rhss1 <- mapM (mkCFItems m) rhss0 -- :: [([Label], [[PreCFItem]])] - mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat - --- | making sequences of CF items from every branch in a linearization -mkCFItems :: Ident -> ([Label], Term) -> Err ([Label], [[PreCFItem]]) -mkCFItems m (labs,t) = do - items <- term2CFItems m t - return (labs, items) - --- | making CF rules from sequences of CF items -mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> ([Label], [[PreCFItem]]) -> Err [CFRule] -mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss - where - mkOneRule its = do - let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its] - profile = mkProfile nonterms - cfcat = labels2CFCat (redirectIdent m cat) lab - cffun = CFFun (AC (CIQ m fun), profile) - cfits = map precf2cf its - return (cffun,(cfcat,cfits)) - mkProfile nonterms = map mkOne args - where - mkOne (A c i) = mkOne (AB c 0 i) - mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i]) - where - mkB x = [k | (k,(j, [LV y], False)) <- nonterms, j == i, y == x] - --- | intermediate data structure of CFItems with information for profiles -data PreCFItem = - PTerm RegExp -- ^ like ordinary Terminal - | PNonterm CIdent Integer [Label] Bool -- ^ cat, position, part\/bind, whether arg - deriving Eq - -precf2cf :: PreCFItem -> CFItem -precf2cf (PTerm r) = CFTerm r -precf2cf (PNonterm cm _ ls True) = CFNonterm (labels2CFCat cm ls) -precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF - - --- | the main job in translating linearization rules into sequences of cf items -term2CFItems :: Ident -> Term -> Err [[PreCFItem]] -term2CFItems m t = errIn "forming cf items" $ case t of - S c _ -> t2c c - - T _ cc -> do - its <- mapM t2c [t | Cas _ t <- cc] - tryMkCFTerm (concat its) - V _ cc -> do - its <- mapM t2c [t | t <- cc] - tryMkCFTerm (concat its) - - C t1 t2 -> do - its1 <- t2c t1 - its2 <- t2c t2 - return [x ++ y | x <- its1, y <- its2] - - FV ts -> do - its <- mapM t2c ts - tryMkCFTerm (concat its) - - P (S c _) _ -> t2c c --- w-around for bug in Compute? AR 31/1/2006 - - P arg s -> extrR arg s - - K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]] - - E -> return [[]] - - K (KP d vs) -> do - let its = [PTerm (RegAlts [s]) | s <- d] - let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs] - tryMkCFTerm (its : itss) - - _ -> return [] ---- prtBad "no cf for" t ---- - - where - - t2c = term2CFItems m - - -- optimize the number of rules by a factorization - tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]] - tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss = - case mapM mkOne (counterparts ii) of - Ok tt -> return [tt] - _ -> return ii - where - mkOne cfits = case mapM mkOneTerm cfits of - Ok tt -> return $ PTerm (RegAlts (concat (nub tt))) - _ -> mkOneNonTerm cfits - mkOneTerm (PTerm (RegAlts t)) = return t - mkOneTerm _ = Bad "" - mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) = - if all (== n) cc - then return n - else Bad "" - mkOneNonTerm _ = Bad "" - counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]] - tryMkCFTerm itss = return itss - - extrR arg lab = case (arg0,labs) of - (Arg (A cat pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]] - (Arg (AB cat b pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]] - (Arg (A cat pos), _) -> return [[PNonterm (cIQ cat) pos labs True]] - (Arg (AB cat b pos), _) -> return [[PNonterm (cIQ cat) pos labs True]] - ---- ?? - _ -> prtBad "cannot extract record field from" arg - where - (arg0,labs) = headProj arg [lab] - - headProj r ls = case r of - P r0 l0 -> headProj r0 (l0:ls) - S r0 _ -> headProj r0 ls - _ -> (r,ls) - cIQ c = if isPredefCat c then CIQ cPredefAbs c else CIQ m c - -mkCFPredef :: Options -> [Ident] -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef) -mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where - (ruls,preds) = if oElem lexerByNeed opts -- option -cflexer - then predefLexer rules - else (rules,emptyTrie) - preds0 s = - [(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++ - [(cat, varCFFun x) | TV x <- [s], cat <- catVarCF : bindcats] ++ - [(cfCatString, stringCFFun t) | TL t <- [s]] ++ - [(cfCatInt, intCFFun t) | TI t <- [s]] ++ - [(cfCatFloat, floatCFFun t) | TF t <- [s]] - cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its] - bindcats = [c | c <- cats, elem (cfCat2Ident c) binds] - look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens - ---- TODO: integrate with morphology ---- predefLexer :: [CFRuleGroup] -> ([CFRuleGroup],BinTree (CFTok,[(CFCat, CFFun)])) -predefLexer groups = (reverse ruls, tcompile preds) where - (ruls,preds) = foldr mkOne ([],[]) groups - mkOne group@(cat,rules) (rs,ps) = (rule:rs,pre ++ ps) where - (rule,pre) = case partition isLexical rules of - ([],_) -> (group,[]) - (ls,rest) -> ((cat,rest), concatMap mkLexRule ls) - isLexical (f,(c,its)) = case its of - [CFTerm (RegAlts ws)] -> True - _ -> False - mkLexRule r = case r of - (fun,(cat,[CFTerm (RegAlts ws)])) -> [(w, [(cat,fun)]) | w <- ws] - _ -> [] diff --git a/src-3.0/GF/CF/ChartParser.hs b/src-3.0/GF/CF/ChartParser.hs deleted file mode 100644 index 740c4d787..000000000 --- a/src-3.0/GF/CF/ChartParser.hs +++ /dev/null @@ -1,206 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ChartParser --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:12 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.10 $ --- --- Bottom-up Kilbury chart parser from "Pure Functional Parsing", chapter 5. --- OBSOLETE -- should use new MCFG parsers instead ------------------------------------------------------------------------------ - -module GF.CF.ChartParser (chartParser) where - --- import Tracing --- import PrintParser --- import PrintSimplifiedTerm - -import GF.Data.Operations -import GF.CF.CF -import GF.CF.CFIdent -import GF.CF.PPrCF (prCFItem) - -import GF.Data.OrdSet -import GF.Data.OrdMap2 - -import Data.List (groupBy) - -type Token = CFTok -type Name = CFFun -type Category = CFItem -type Grammar = ([Production], Terminal) -type Production = (Name, Category, [Category]) -type Terminal = Token -> [(Category, Maybe Name)] -type GParser = Grammar -> Category -> [Token] -> ([ParseTree],String) -data ParseTree = Node Name Category [ParseTree] | Leaf Token - -maxTake :: Int --- maxTake = 1000 -maxTake = maxBound - --------------------------------------------------- --- converting between GF parsing and CFG parsing - -buildParser :: GParser -> CF -> CFCat -> CFParser -buildParser gparser cf = parse - where - parse = \start input -> - let parse2 = parse' (CFNonterm start) input in - (take maxTake [(parse2tree t, []) | t <- fst parse2], snd parse2) - parse' = gparser (cf2grammar cf) - -cf2grammar :: CF -> Grammar -cf2grammar cf = (productions, terminal) - where - productions = [ (name, CFNonterm cat, rhs) | - (name, (cat, rhs)) <- cfRules ] - terminal tok = [ (CFNonterm cat, Just name) | - (cat, name) <- cfPredef tok ] - ++ - [ (item, Nothing) | - item <- elems rhsItems, - matchCFTerm item tok ] - cfRules = rulesOfCF cf - cfPredef = predefOfCF cf - rhsItems :: Set Category - rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ] - -parse2tree :: ParseTree -> CFTree -parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees')) - where - trees' = [ parse2tree t | t@(Node _ _ _) <- trees ] -- ignore leafs - -maybeNode :: Maybe Name -> Category -> Token -> ParseTree -maybeNode (Just name) cat tok = Node name cat [Leaf tok] -maybeNode Nothing _ tok = Leaf tok - - --------------------------------------------------- --- chart parsing (bottom up kilbury-like) - -type Chart = [CState] -type CState = Set Edge -type Edge = (Int, Category, [Category]) -type Passive = (Int, Int, Category) - -chartParser :: CF -> CFCat -> CFParser -chartParser = buildParser chartParser0 - -chartParser0 :: GParser -chartParser0 (productions, terminal) = cparse - where - emptyCats :: Set Category - emptyCats = empties emptySet - where - empties cats | cats==cats' = cats - | otherwise = empties cats' - where cats' = makeSet [ cat | (_, cat, rhs) <- productions, - all (`elemSet` cats) rhs ] - - grammarMap :: Map Category [(Name, [Category])] - grammarMap = makeMapWith (++) - [ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ] - - leftCornerMap :: Map Category (Set (Category,[Category])) - leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) | - (_, b, abs) <- productions, - (a : bs) <- removeNullable abs ] - - removeNullable :: [Category] -> [[Category]] - removeNullable [] = [] - removeNullable cats@(cat:cats') - | cat `elemSet` emptyCats = cats : removeNullable cats' - | otherwise = [cats] - - cparse :: Category -> [Token] -> ([ParseTree], String) - cparse start input = -- trace "ChartParser" $ - case lookup (0, length input, start) $ - -- tracePrt "#edgeTrees" (prt . map (length.snd)) $ - edgeTrees of - Just trees -> -- tracePrt "#trees" (prt . length . fst) $ - (trees, "Chart:" ++++ prChart passiveEdges) - Nothing -> ([], "Chart:" ++++ prChart passiveEdges) - where - finalChart :: Chart - finalChart = map buildState initialChart - - finalChartMap :: [Map Category (Set Edge)] - finalChartMap = map stateMap finalChart - - stateMap :: CState -> Map Category (Set Edge) - stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) | - (i, b, a:bs) <- elems state ] - - initialChart :: Chart - initialChart = -- tracePrt "#initialChart" (prt . map (length.elems)) $ - emptySet : map initialState (zip [0..] input) - where initialState (j, sym) = makeSet [ (j, cat, []) | - (cat, _) <- terminal sym ] - - buildState :: CState -> CState - buildState = limit more - where more (j, a, []) = ordSet [ (j, b, bs) | - (b, bs) <- elems (lookupWith emptySet leftCornerMap a) ] - <++> - lookupWith emptySet (finalChartMap !! j) a - more (j, b, a:bs) = ordSet [ (j, b, bs) | - a `elemSet` emptyCats ] - - passiveEdges :: [Passive] - passiveEdges = -- tracePrt "#passiveEdges" (prt . length) $ - [ (i, j, cat) | - (j, state) <- zip [0..] $ - -- tracePrt "#passiveChart" - -- (prt . map (length.filter (\(_,_,x)->null x).elems)) $ - -- tracePrt "#activeChart" (prt . map (length.elems)) $ - finalChart, - (i, cat, []) <- elems state ] - ++ - [ (i, i, cat) | - i <- [0 .. length input], - cat <- elems emptyCats ] - - edgeTrees :: [ (Passive, [ParseTree]) ] - edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ] - - edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])] - edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) | - ((i,j,c), trees) <- edgeTrees ] - - treesFor :: Passive -> [ParseTree] - treesFor (i, j, cat) = [ Node name cat trees | - (name, rhs) <- lookupWith [] grammarMap cat, - trees <- children rhs i j ] - ++ - [ maybeNode name cat tok | - i == j-1, - let tok = input !! i, - Just name <- [lookup cat (terminal tok)] ] - - children :: [Category] -> Int -> Int -> [[ParseTree]] - children [] i k = [ [] | i == k ] - children (c:cs) i k = [ tree : rest | - i <= k, - (j, trees) <- lookupWith [] edgeTreesMap (i,c), - rest <- children cs j k, - tree <- trees ] - - -{- -instance Print ParseTree where - prt (Node name cat trees) = prt name++"."++prt cat++"^{"++prtSep "," trees++"}" - prt (Leaf token) = prt token --} - --- AR 10/12/2002 - -prChart :: [Passive] -> String -prChart = unlines . map (unwords . map prOne) . positions where - prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it - positions = groupBy (\ (i,_,_) (j,_,_) -> i == j) - - diff --git a/src-3.0/GF/CF/EBNF.hs b/src-3.0/GF/CF/EBNF.hs deleted file mode 100644 index f091d19cb..000000000 --- a/src-3.0/GF/CF/EBNF.hs +++ /dev/null @@ -1,191 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : EBNF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:13 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.CF.EBNF (pEBNFasGrammar) where - -import GF.Data.Operations -import GF.Data.Parsers -import GF.Infra.Comments -import GF.CF.CF -import GF.CF.CFIdent -import GF.Grammar.Grammar -import GF.Grammar.PrGrammar -import GF.CF.CFtoGrammar -import qualified GF.Source.AbsGF as A - -import Data.List (nub, partition) - --- AR 18/4/2000 - 31/3/2004 - --- Extended BNF grammar with token type a --- put a = String for simple applications - -type EBNF = [ERule] -type ERule = (ECat, ERHS) -type ECat = (String,[Int]) -type ETok = String - -ebnfID = "EBNF" ---- make this parametric! - -data ERHS = - ETerm ETok - | ENonTerm ECat - | ESeq ERHS ERHS - | EAlt ERHS ERHS - | EStar ERHS - | EPlus ERHS - | EOpt ERHS - | EEmpty - -type CFRHS = [CFItem] -type CFJustRule = (CFCat, CFRHS) - -ebnf2gf :: EBNF -> [A.TopDef] -ebnf2gf = cf2grammar . rules2CF . ebnf2cf - -ebnf2cf :: EBNF -> [CFRule] -ebnf2cf ebnf = [(mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where - mkCFF i (CFCat (_,c), _) = string2CFFun ebnfID ("Mk" ++ prt c ++ "_" ++ show i) - -normEBNF :: EBNF -> [CFJustRule] -normEBNF erules = let - erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules] - erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad ! - erules3 = concat (map pickERules erules2) - erules4 = nubERules erules3 - in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss] - -refreshECats :: [NormERule] -> [NormERule] -refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where - recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its]) - recss ii n [] = [] - recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss - recit ii it = case it of - EINonTerm cat -> EINonTerm (updECat ii cat) - EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t]) - EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t]) - EIOpt (cat,t) -> EIOpt (updECat ii cat, [recss ii 0 s | s <- t]) - _ -> it - -pickERules :: NormERule -> [NormERule] -pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where - pics it = case it of - EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru - EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru - EIOpt ru@(cat,t) -> mkEOptRules cat ++ pickERules ru - _ -> [] - mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])] - where cat' = mkNewECat cat "Star" - mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])] - where cat' = mkNewECat cat "Plus" - mkEOptRules cat = [(cat', [[],[EINonTerm cat]])] - where cat' = mkNewECat cat "Opt" - -nubERules :: [NormERule] -> [NormERule] -nubERules rules = nub optim where - optim = map (substERules (map mkSubst replaces)) irreducibles - (replaces,irreducibles) = partition reducible rules - reducible (cat,[items]) = isNewCat cat && all isOldIt items - reducible _ = False - isNewCat (_,ints) = ints == [] - isOldIt (EITerm _) = True - isOldIt (EINonTerm cat) = not (isNewCat cat) - isOldIt _ = False - mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton ---- the optimization assumes each cat has at most one EBNF rule. - -substERules :: [(ECat,[EItem])] -> NormERule -> NormERule -substERules g (cat,itss) = (cat, map sub itss) where - sub [] = [] - sub (i@(EINonTerm cat') : ii) = case lookup cat g of - Just its -> its ++ sub ii - _ -> i : sub ii - sub (EIStar r : ii) = EIStar (substERules g r) : ii - sub (EIPlus r : ii) = EIPlus (substERules g r) : ii - sub (EIOpt r : ii) = EIOpt (substERules g r) : ii - -eitem2cfitem :: EItem -> CFItem -eitem2cfitem it = case it of - EITerm a -> atomCFTerm $ tS a - EINonTerm cat -> CFNonterm (mkCFCatE cat) - EIStar (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Star")) - EIPlus (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Plus")) - EIOpt (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Opt")) - -type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items - -data EItem = - EITerm String - | EINonTerm ECat - | EIStar NormERule - | EIPlus NormERule - | EIOpt NormERule - deriving Eq - -normERule :: ([Int],ERule) -> NormERule -normERule (ii,(cat,rhs)) = - (cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where - disjNorm r = case r of - ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2] - EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2 - EEmpty -> [[]] - _ -> [[r]] - -mkEItem :: [Int] -> ERHS -> EItem -mkEItem ii rhs = case rhs of - ETerm a -> EITerm a - ENonTerm cat -> EINonTerm cat - EStar r -> EIStar (normERule (ii,(mkECat ii, r))) - EPlus r -> EIPlus (normERule (ii,(mkECat ii, r))) - EOpt r -> EIOpt (normERule (ii,(mkECat ii, r))) - _ -> EINonTerm ("?????",[]) --- _ -> error "should not happen in ebnf" --- - -mkECat ints = ("C", ints) - -prECat (c,[]) = c -prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints) - -mkCFCatE :: ECat -> CFCat -mkCFCatE = string2CFCat ebnfID . prECat - -updECat _ (c,[]) = (c,[]) -updECat ii (c,_) = (c,ii) - -mkNewECat (c,ii) str = (c ++ str,ii) - ------- parser for EBNF grammars - -pEBNFasGrammar :: String -> Err [A.TopDef] -pEBNFasGrammar = parseResultErr (pEBNF *** ebnf2gf) . remComments - -pEBNF :: Parser Char EBNF -pEBNF = longestOfMany (pJ pERule) - -pERule :: Parser Char ERule -pERule = pECat ... pJ (literals ":=" ||| literals "::=") +.. pERHS 0 ..+ jL ";" - -pERHS :: Int -> Parser Char ERHS -pERHS 0 = pTList "|" (pERHS 1) *** foldr1 EAlt -pERHS 1 = longestOfMany (pJ (pERHS 2)) *** foldr ESeq EEmpty -pERHS 2 = pERHS 3 ... pJ pUnaryEOp *** (\ (a,f) -> f a) -pERHS 3 = pQuotedString *** ETerm - ||| pECat *** ENonTerm ||| pParenth (pERHS 0) - -pUnaryEOp :: Parser Char (ERHS -> ERHS) -pUnaryEOp = - lits "*" <<< EStar ||| lits "+" <<< EPlus ||| lits "?" <<< EOpt ||| succeed id - -pECat = pIdent *** (\c -> (c,[])) - diff --git a/src-3.0/GF/CF/PPrCF.hs b/src-3.0/GF/CF/PPrCF.hs deleted file mode 100644 index 1c2203e94..000000000 --- a/src-3.0/GF/CF/PPrCF.hs +++ /dev/null @@ -1,102 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PPrCF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003 --- --- use the Print class instead! ------------------------------------------------------------------------------ - -module GF.CF.PPrCF (prCF, prCFTree, prCFRule, prCFFun, prCFCat, prCFItem, prRegExp, pCF) where - -import GF.Data.Operations -import GF.CF.CF -import GF.CF.CFIdent -import GF.Canon.AbsGFC -import GF.Grammar.PrGrammar - -import Data.Char -import Data.List - -prCF :: CF -> String -prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function - -prCFTree :: CFTree -> String -prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where - prs [] = "" - prs ts = " " ++ unwords (map ps ts) - ps t@(CFTree (_,(_,[]))) = prCFTree t - ps t = prParenth (prCFTree t) -{-# NOINLINE prCFTree #-} --- Workaround ghc 6.8.2 bug - - -prCFRule :: CFRule -> String -prCFRule (fun,(cat,its)) = - prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++ - unwords (map prCFItem its) +++ ";" - -prCFFun :: CFFun -> String -prCFFun = prCFFun' True ---- False -- print profiles for debug - -prCFFun' :: Bool -> CFFun -> String -prCFFun' profs (CFFun (t, p)) = prt_ t ++ pp p where - pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p) - normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])] - -prCFCat :: CFCat -> String -prCFCat (CFCat (c,l)) = prt_ c ++ case prt_ l of - "s" -> [] - _ -> "-" ++ prt_ l ---- - -prCFItem :: CFItem -> String -prCFItem (CFNonterm c) = prCFCat c -prCFItem (CFTerm a) = prRegExp a - -prRegExp :: RegExp -> String -prRegExp (RegAlts tt) = case tt of - [t] -> prQuotedString t - _ -> prParenth (prTList " | " (map prQuotedString tt)) - --- rules have an amazingly easy parser, if we use the format --- fun. C -> item1 item2 ... where unquoted items are treated as cats --- Actually would be nice to add profiles to this. - -getCFRule :: String -> String -> Err [CFRule] -getCFRule mo s = getcf (wrds s) where - getcf ws = case ws of - fun : cat : a : its | isArrow a -> - Ok [(string2CFFun mo (init fun), - (string2CFCat mo cat, map mkIt its))] - cat : a : its | isArrow a -> - Ok [(string2CFFun mo (mkFun cat it), - (string2CFCat mo cat, map mkIt it)) | it <- chunk its] - _ -> Bad (" invalid rule:" +++ s) - isArrow a = elem a ["->", "::="] - mkIt w = case w of - ('"':w@(_:_)) -> atomCFTerm (string2CFTok (init w)) - _ -> CFNonterm (string2CFCat mo w) - chunk its = case its of - [] -> [[]] - _ -> chunks "|" its - mkFun cat its = case its of - [] -> cat ++ "_" - _ -> concat $ intersperse "_" (cat : map clean its) -- CLE style - clean = filter isAlphaNum -- to form valid identifiers - wrds = takeWhile (/= ";") . words -- to permit semicolon in the end - -pCF :: String -> String -> Err [CFRule] -pCF mo s = do - rules <- mapM (getCFRule mo) $ filter isRule $ lines s - return $ concat rules - where - isRule line = case dropWhile isSpace line of - '-':'-':_ -> False - _ -> not $ all isSpace line diff --git a/src-3.0/GF/CF/PrLBNF.hs b/src-3.0/GF/CF/PrLBNF.hs deleted file mode 100644 index 4ba2019bc..000000000 --- a/src-3.0/GF/CF/PrLBNF.hs +++ /dev/null @@ -1,150 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrLBNF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.11 $ --- --- Printing CF grammars generated from GF as LBNF grammar for BNFC. --- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 -- 27/9/2004. --- With primitive error messaging, by rules and rule tails commented out ------------------------------------------------------------------------------ - -module GF.CF.PrLBNF (prLBNF,prBNF) where - -import GF.CF.CF -import GF.CF.CFIdent -import GF.Canon.AbsGFC -import GF.Infra.Ident -import GF.Grammar.PrGrammar -import GF.Compile.ShellState -import GF.Canon.GFC -import GF.Canon.Look - -import GF.Data.Operations -import GF.Infra.Modules - -import Data.Char -import Data.List (nub) - -prLBNF :: Bool -> StateGrammar -> String -prLBNF new gr = unlines $ pragmas ++ (map (prCFRule cs) rules') - where - cs = map IC ["Int","String"] ++ [catIdPlus c | (_,(c,_)) <- rules] - cf = stateCF gr - (pragmas,rules) = if new -- tries to treat precedence levels - then mkLBNF (stateGrammarST gr) $ rulesOfCF cf - else ([],rulesOfCF cf) -- "normal" behaviour - rules' = concatMap expand rules - expand (f,(c,its)) = [(f,(c,it)) | it <- combinations (map expIt its)] - expIt i = case i of - CFTerm (RegAlts ss) -> [CFTerm (RegAlts [s]) | s <- ss] - _ -> [i] - --- | a hack to hide the LBNF details -prBNF :: Bool -> StateGrammar -> String -prBNF b = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF b - where - unLBNF r = case r of - "---":ts -> ts - ";":"---":ts -> ts - c:ts -> c : unLBNF ts - _ -> r - ---- | awful low level code without abstraction over label names etc -mkLBNF :: CanonGrammar -> [CFRule] -> ([String],[CFRule]) -mkLBNF gr rules = (coercions, nub $ concatMap mkRule rules) where - coercions = ["coercions" +++ prt_ c +++ show n +++ ";" | - (_,ModMod m) <- modules gr, - (c,CncCat (RecType ls) _ _) <- tree2list $ jments m, - Lbg (L (IC "p")) (TInts n) <- ls - ] - precedences = [(f,(prec,assoc)) | - (_,ModMod m) <- modules gr, - (f,CncFun _ _ (R lin) _) <- tree2list $ jments m, - (Just prec, Just assoc) <- [( - lookup "p" [(lab,p) | Ass (L (IC lab)) (EInt p) <- lin], - lookup "a" [(lab,a) | Ass (L (IC lab)) (Par (CIQ _ (IC a)) []) <- lin] - )] - ] - precfuns = map fst precedences - mkRule r@(fun@(CFFun (t, p)),(cat,its)) = case t of - AC (CIQ _ c) -> case lookup c precedences of - Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))] - _ -> return r - AD (CIQ _ c) -> case lookup c precedences of - Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))] - _ -> return r - _ -> return r - mkIts cat prec assoc i its = case its of - CFTerm (RegAlts ["("]):n@(CFNonterm k):CFTerm (RegAlts [")"]):rest | k==cat -> - mkIts cat prec assoc i $ n:rest -- remove variants with parentheses - CFNonterm k:rest | k==cat -> - CFNonterm (mkNonterm prec assoc i k) : mkIts cat prec assoc (i+1) rest - it:rest -> it:mkIts cat prec assoc i rest - [] -> [] - - mkCat prec (CFCat ((CIQ m (IC c)),l)) = CFCat ((CIQ m (IC (c ++ show prec ++ "+"))),l) - mkNonterm prec assoc i cat = mkCat prec' cat - where - prec' = case (assoc,i) of - ("PL",0) -> prec - ("PR",0) -> prec + 1 - ("PR",_) -> prec - _ -> prec + 1 - -catId ((CFCat ((CIQ _ c),l))) = c - -catIdPlus ((CFCat ((CIQ _ c@(IC s)),l))) = case reverse s of - '+':cs -> IC $ reverse $ dropWhile isDigit cs - _ -> c - -prCFRule :: [Ident] -> CFRule -> String -prCFRule cs (fun,(cat,its)) = - prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax - unwords (map (prCFItem cs) its) +++ ";" - -prCFFun :: CFCat -> CFFun -> String -prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of - AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) - AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) - _ -> prErr True $ prt t - where - lab = prLab l - f2 f = if null lab then "" else f - prP = concatMap show - -prId b i = case i of - IC "Int" -> "Integer" - IC "#Var" -> "Ident" - IC "Var" -> "Ident" - IC "id_" -> "_" - IC s@(c:_) | last s == '+' -> init s -- hack to save precedence information - IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else "" - _ -> prErr b $ prt i - -prLab i = case i of - L (IC "s") -> "" --- - L (IC "_") -> "" --- - _ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else "" - --- | just comment out the rest if you cannot interpret the function name in LBNF --- two versions, depending on whether in the beginning of a rule or elsewhere; --- in the latter case, error just terminates the rule -prErr :: Bool -> String -> String -prErr b s = (if b then "" else " ;") +++ "---" +++ s - -prCFCat :: Bool -> CFCat -> String -prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ---- - --- | if a category does not have a production of its own, we replace it by Ident -prCFItem cs (CFNonterm c) = if elem (catIdPlus c) cs then prCFCat False c else "Ident" -prCFItem _ (CFTerm a) = prRegExp a - -prRegExp (RegAlts tt) = case tt of - [t] -> prQuotedString t - _ -> prErr False $ prParenth (prTList " | " (map prQuotedString tt)) diff --git a/src-3.0/GF/CF/Profile.hs b/src-3.0/GF/CF/Profile.hs deleted file mode 100644 index e573bec78..000000000 --- a/src-3.0/GF/CF/Profile.hs +++ /dev/null @@ -1,106 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Profile --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:14 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001 --- revised 8/4/2002 for the new profile structure ------------------------------------------------------------------------------ - -module GF.CF.Profile (postParse) where - -import GF.Canon.AbsGFC -import GF.Canon.GFC -import qualified GF.Infra.Ident as I -import GF.Canon.CMacros ----import MMacros -import GF.CF.CF -import GF.CF.CFIdent -import GF.CF.PPrCF -- for error msg -import GF.Grammar.PrGrammar - -import GF.Data.Operations - -import Control.Monad -import Data.List (nub) - --- | the job is done in two passes: --- --- 1. tree2term: restore constituent order from Profile --- --- 2. term2trm: restore Bindings from Binds -postParse :: CFTree -> Err Exp -postParse tree = do - iterm <- errIn ("postprocessing parse tree" +++ prCFTree tree) $ tree2term tree - return $ term2trm iterm - --- | an intermediate data structure -data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta deriving (Eq,Show) -type BindVs = [[I.Ident]] - --- | (1) restore constituent order from Profile -tree2term :: CFTree -> Err ITerm --- tree2term (CFTree (f,(_,[t]))) | f == dummyCFFun = tree2term t -- not used -tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of - AM _ -> return IMeta - _ -> do - args <- mapM mkArg pro - binds <- mapM mkBinds pro - return $ ITerm (fun, binds) args - where - mkArg (_,arg) = case arg of - [x] -> do -- one occurrence - trx <- trees !? x - tree2term trx - [] -> return IMeta -- suppression - _ -> do -- reduplication - trees' <- mapM (trees !?) arg - xs1 <- mapM tree2term trees' - xs2 <- checkArity xs1 - unif xs2 - - checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 - then Bad "arity error" - else return xs' - where xs' = [t | t@(ITerm _ _) <- xs] - unif xs = case [t | t@(ITerm _ _) <- xs] of - [] -> return $ IMeta - (ITerm fp@(f,_) xx : ts) -> do - let hs = [h | ITerm (h,_) _ <- ts, h /= f] - testErr (null hs) -- if fails, hs must be nonempty - ("unification expects" +++ prt f +++ "but found" +++ prt (head hs)) - xx' <- mapM unifArg [0 .. length xx - 1] - return $ ITerm fp xx' - where - unifArg i = unif [zz !! i | ITerm _ zz <- xs] - - mkBinds (xss,_) = mapM mkBind xss - mkBind xs = do - ts <- mapM (trees !?) xs - let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts] - testErr (length ts == length vs) "non-variable in bound position" - case vs of - [x] -> return x - [] -> return $ I.identC "h_" ---- uBoundVar - y:ys -> do - testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y) - return y - --- | (2) restore Bindings from Binds -term2trm :: ITerm -> Exp -term2trm IMeta = EAtom (AM 0) ---- mExp0 -term2trm (ITerm (fun, binds) terms) = - let bterms = zip binds terms - in mkAppAtom fun [mkAbsR xs (term2trm t) | (xs,t) <- bterms] - - --- these are deprecated - where - mkAbsR c e = foldr EAbs e c - mkAppAtom a = mkApp (EAtom a) - mkApp = foldl EApp diff --git a/src-3.0/GF/CFGM/AbsCFG.hs b/src-3.0/GF/CFGM/AbsCFG.hs deleted file mode 100644 index 063b96802..000000000 --- a/src-3.0/GF/CFGM/AbsCFG.hs +++ /dev/null @@ -1,45 +0,0 @@ -module GF.CFGM.AbsCFG where - --- Haskell module generated by the BNF converter - -newtype Ident = Ident String deriving (Eq,Ord,Show) -newtype SingleQuoteString = SingleQuoteString String deriving (Eq,Ord,Show) -data Grammars = - Grammars [Grammar] - deriving (Eq,Ord,Show) - -data Grammar = - Grammar Ident [Flag] [Rule] - deriving (Eq,Ord,Show) - -data Flag = - StartCat Category - deriving (Eq,Ord,Show) - -data Rule = - Rule Fun Profiles Category [Symbol] - deriving (Eq,Ord,Show) - -data Fun = - Cons Ident - | Coerce - deriving (Eq,Ord,Show) - -data Profiles = - Profiles [Profile] - deriving (Eq,Ord,Show) - -data Profile = - UnifyProfile [Integer] - | ConstProfile Ident - deriving (Eq,Ord,Show) - -data Symbol = - CatS Category - | TermS String - deriving (Eq,Ord,Show) - -data Category = - Category SingleQuoteString - deriving (Eq,Ord,Show) - diff --git a/src-3.0/GF/CFGM/CFG.cf b/src-3.0/GF/CFGM/CFG.cf deleted file mode 100644 index fa722f4a4..000000000 --- a/src-3.0/GF/CFGM/CFG.cf +++ /dev/null @@ -1,36 +0,0 @@ -entrypoints Grammars; - -Grammars. Grammars ::= [Grammar]; - -Grammar. Grammar ::= "grammar" Ident [Flag] [Rule] "end" "grammar"; -separator Grammar ""; - -StartCat. Flag ::= "startcat" Category; -terminator Flag ";"; - -Rule. Rule ::= Fun ":" Profiles "." Category "->" [Symbol]; -terminator Rule ";"; - -Cons. Fun ::= Ident ; -Coerce. Fun ::= "_" ; - -Profiles. Profiles ::= "[" [Profile] "]"; - -separator Profile ","; - -UnifyProfile. Profile ::= "[" [Integer] "]"; -ConstProfile. Profile ::= Ident ; - -separator Integer ","; - -CatS. Symbol ::= Category; -TermS. Symbol ::= String; - --- separator Symbol ""; -[]. [Symbol] ::= "." ; -(:[]). [Symbol] ::= Symbol ; -(:). [Symbol] ::= Symbol [Symbol] ; - -Category. Category ::= SingleQuoteString ; - -token SingleQuoteString '\'' ((char - ["'\\"]) | ('\\' ["'\\"]))* '\'' ; diff --git a/src-3.0/GF/CFGM/LexCFG.hs b/src-3.0/GF/CFGM/LexCFG.hs deleted file mode 100644 index e58fdff5a..000000000 --- a/src-3.0/GF/CFGM/LexCFG.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "LexCFG.x" #-} -module GF.CFGM.LexCFG where - -import GF.Data.ErrM - - -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\xf8\xff\xfd\xff\x02\x00\x00\x00\xd2\xff\x00\x00\xfa\xff\xfc\xff\x2d\x00\xc8\x00\x98\x01\x00\x00\x73\x00\x43\x01\x01\x01\x43\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x02\x00\x00\x00\x06\x00\x00\x00\x05\x00\x02\x00\x05\x00\x03\x00\x04\x00\x03\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x03\x00\x07\x00\x03\x00\x08\x00\x03\x00\x08\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0e\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0e\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\x20\x00\xff\xff\x27\x00\xff\xff\x27\x00\x20\x00\x27\x00\x2c\x00\x2d\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x27\x00\x5d\x00\x5c\x00\x5f\x00\x5c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,15) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[],[(AlexAcc (alex_action_2))],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[],[(AlexAcc (alex_action_5))]] -{-# LINE 33 "LexCFG.x" #-} - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - | T_SingleQuoteString !String - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - PT _ (T_SingleQuoteString s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "grammar" (b "end" N N) (b "startcat" N N) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c - -alex_action_1 = tok (\p s -> PT p (TS $ share s)) -alex_action_2 = tok (\p s -> PT p (eitherResIdent (T_SingleQuoteString . share) s)) -alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_4 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) -alex_action_5 = tok (\p s -> PT p (TI $ share s)) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - - -{-# LINE 35 "GenericTemplate.hs" #-} - - - - - - - - - - - -data AlexAddr = AlexA# Addr# - -{-# INLINE alexIndexShortOffAddr #-} -alexIndexShortOffAddr (AlexA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - case s of - -1# -> (last_acc, input) - _ -> alex_scan_tkn' user orig_input len input s last_acc - -alex_scan_tkn' user orig_input len input s last_acc = - let - new_acc = check_accs (alex_accept `unsafeAt` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexShortOffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexShortOffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexShortOffAddr alex_table offset - else alexIndexShortOffAddr alex_deflt s - in - alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src-3.0/GF/CFGM/LexCFG.x b/src-3.0/GF/CFGM/LexCFG.x deleted file mode 100644 index f3ecb14eb..000000000 --- a/src-3.0/GF/CFGM/LexCFG.x +++ /dev/null @@ -1,135 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -module LexCFG where - -import ErrM - -} - - -$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME -$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME -$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME -$d = [0-9] -- digit -$i = [$l $d _ '] -- identifier character -$u = [\0-\255] -- universal: any character - -@rsyms = -- reserved words consisting of special symbols - \; | \: | \. | \- \> | \_ | \[ | \] | \, - -:- - -$white+ ; -@rsyms { tok (\p s -> PT p (TS $ share s)) } -\' ($u # [\' \\]| \\ [\' \\]) * \' { tok (\p s -> PT p (eitherResIdent (T_SingleQuoteString . share) s)) } - -$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } -\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) } - -$d+ { tok (\p s -> PT p (TI $ share s)) } - - -{ - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - | T_SingleQuoteString !String - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - PT _ (T_SingleQuoteString s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "grammar" (b "end" N N) (b "startcat" N N) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c -} diff --git a/src-3.0/GF/CFGM/ParCFG.hs b/src-3.0/GF/CFGM/ParCFG.hs deleted file mode 100644 index cb70ef30d..000000000 --- a/src-3.0/GF/CFGM/ParCFG.hs +++ /dev/null @@ -1,779 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -module GF.CFGM.ParCFG where -import GF.CFGM.AbsCFG -import GF.CFGM.LexCFG -import GF.Data.ErrM -import Array -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.15 - -newtype HappyAbsSyn = HappyAbsSyn (() -> ()) -happyIn4 :: (Ident) -> (HappyAbsSyn ) -happyIn4 x = unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (Ident) -happyOut4 x = unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (Integer) -> (HappyAbsSyn ) -happyIn5 x = unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Integer) -happyOut5 x = unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (String) -> (HappyAbsSyn ) -happyIn6 x = unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (String) -happyOut6 x = unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (SingleQuoteString) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (SingleQuoteString) -happyOut7 x = unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Grammars) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (Grammars) -happyOut8 x = unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Grammar) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Grammar) -happyOut9 x = unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: ([Grammar]) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> ([Grammar]) -happyOut10 x = unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Flag) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Flag) -happyOut11 x = unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: ([Flag]) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> ([Flag]) -happyOut12 x = unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (Rule) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (Rule) -happyOut13 x = unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: ([Rule]) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> ([Rule]) -happyOut14 x = unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (Fun) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (Fun) -happyOut15 x = unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (Profiles) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (Profiles) -happyOut16 x = unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([Profile]) -> (HappyAbsSyn ) -happyIn17 x = unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([Profile]) -happyOut17 x = unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Profile) -> (HappyAbsSyn ) -happyIn18 x = unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (Profile) -happyOut18 x = unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([Integer]) -> (HappyAbsSyn ) -happyIn19 x = unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> ([Integer]) -happyOut19 x = unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (Symbol) -> (HappyAbsSyn ) -happyIn20 x = unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Symbol) -happyOut20 x = unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: ([Symbol]) -> (HappyAbsSyn ) -happyIn21 x = unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> ([Symbol]) -happyOut21 x = unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Category) -> (HappyAbsSyn ) -happyIn22 x = unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Category) -happyOut22 x = unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x00\x00\x36\x00\x00\x00\x29\x00\x35\x00\x00\x00\x32\x00\x00\x00\x30\x00\x38\x00\x19\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x34\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x31\x00\xfd\xff\x00\x00\x2c\x00\x2a\x00\x23\x00\x22\x00\x2b\x00\x25\x00\x20\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x28\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x21\x00\x05\x00\x01\x00\x00\x00\x1d\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x02\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xf8\xff\x00\x00\xfe\xff\x00\x00\xfa\xff\xf7\xff\x00\x00\xf5\xff\xf2\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xf6\xff\xfb\xff\xf0\xff\x00\x00\x00\x00\xef\xff\x00\x00\xf4\xff\xf9\xff\x00\x00\xf1\xff\x00\x00\xed\xff\xe9\xff\x00\x00\xec\xff\xe8\xff\x00\x00\x00\x00\xe7\xff\x00\x00\xfd\xff\xed\xff\xee\xff\xeb\xff\xea\xff\xe8\xff\x00\x00\xe4\xff\xe2\xff\xf3\xff\xe5\xff\xe3\xff\xfc\xff\xe6\xff\xe1\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x06\x00\x02\x00\x03\x00\x03\x00\x03\x00\x07\x00\x0c\x00\x00\x00\x0a\x00\x00\x00\x08\x00\x01\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x12\x00\x12\x00\x0d\x00\x0e\x00\x0d\x00\x0e\x00\x01\x00\x0f\x00\x00\x00\x05\x00\x03\x00\x0c\x00\x00\x00\x09\x00\x05\x00\x0d\x00\x0c\x00\x09\x00\x07\x00\x0b\x00\x0f\x00\x0e\x00\x0f\x00\x04\x00\x08\x00\x06\x00\x04\x00\x0d\x00\x0f\x00\x08\x00\x07\x00\x03\x00\x06\x00\x02\x00\x0a\x00\x01\x00\x01\x00\x11\x00\x0b\x00\xff\xff\x0f\x00\x0c\x00\x0a\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x29\x00\x0c\x00\x1e\x00\x29\x00\x0c\x00\x0c\x00\x0c\x00\x09\x00\x03\x00\x1a\x00\x0a\x00\x1a\x00\x08\x00\x20\x00\x2a\x00\x30\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x1f\x00\x0d\x00\x25\x00\x1c\x00\x1b\x00\x1c\x00\x20\x00\x2f\x00\x0f\x00\x13\x00\x2e\x00\x18\x00\x07\x00\x14\x00\x05\x00\x23\x00\x03\x00\x10\x00\x27\x00\x11\x00\x21\x00\x2f\x00\x0f\x00\x03\x00\x28\x00\x04\x00\x29\x00\x23\x00\x0f\x00\x24\x00\x25\x00\x1f\x00\x1a\x00\x17\x00\x16\x00\x18\x00\x15\x00\xff\xff\x0c\x00\x00\x00\x0f\x00\x03\x00\x07\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (1, 31) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31) - ] - -happy_n_terms = 18 :: Int -happy_n_nonterms = 19 :: Int - -happyReduce_1 = happySpecReduce_1 0# happyReduction_1 -happyReduction_1 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> - happyIn4 - (Ident happy_var_1 - )} - -happyReduce_2 = happySpecReduce_1 1# happyReduction_2 -happyReduction_2 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn5 - ((read happy_var_1) :: Integer - )} - -happyReduce_3 = happySpecReduce_1 2# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn6 - (happy_var_1 - )} - -happyReduce_4 = happySpecReduce_1 3# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (T_SingleQuoteString happy_var_1)) -> - happyIn7 - (SingleQuoteString (happy_var_1) - )} - -happyReduce_5 = happySpecReduce_1 4# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn8 - (Grammars (reverse happy_var_1) - )} - -happyReduce_6 = happyReduce 6# 5# happyReduction_6 -happyReduction_6 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut4 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_3 of { happy_var_3 -> - case happyOut14 happy_x_4 of { happy_var_4 -> - happyIn9 - (Grammar happy_var_2 (reverse happy_var_3) (reverse happy_var_4) - ) `HappyStk` happyRest}}} - -happyReduce_7 = happySpecReduce_0 6# happyReduction_7 -happyReduction_7 = happyIn10 - ([] - ) - -happyReduce_8 = happySpecReduce_2 6# happyReduction_8 -happyReduction_8 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn10 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_9 = happySpecReduce_2 7# happyReduction_9 -happyReduction_9 happy_x_2 - happy_x_1 - = case happyOut22 happy_x_2 of { happy_var_2 -> - happyIn11 - (StartCat happy_var_2 - )} - -happyReduce_10 = happySpecReduce_0 8# happyReduction_10 -happyReduction_10 = happyIn12 - ([] - ) - -happyReduce_11 = happySpecReduce_3 8# happyReduction_11 -happyReduction_11 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn12 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happyReduce 7# 9# happyReduction_12 -happyReduction_12 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_3 of { happy_var_3 -> - case happyOut22 happy_x_5 of { happy_var_5 -> - case happyOut21 happy_x_7 of { happy_var_7 -> - happyIn13 - (Rule happy_var_1 happy_var_3 happy_var_5 happy_var_7 - ) `HappyStk` happyRest}}}} - -happyReduce_13 = happySpecReduce_0 10# happyReduction_13 -happyReduction_13 = happyIn14 - ([] - ) - -happyReduce_14 = happySpecReduce_3 10# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - case happyOut13 happy_x_2 of { happy_var_2 -> - happyIn14 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_15 = happySpecReduce_1 11# happyReduction_15 -happyReduction_15 happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - happyIn15 - (Cons happy_var_1 - )} - -happyReduce_16 = happySpecReduce_1 11# happyReduction_16 -happyReduction_16 happy_x_1 - = happyIn15 - (Coerce - ) - -happyReduce_17 = happySpecReduce_3 12# happyReduction_17 -happyReduction_17 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn16 - (Profiles happy_var_2 - )} - -happyReduce_18 = happySpecReduce_0 13# happyReduction_18 -happyReduction_18 = happyIn17 - ([] - ) - -happyReduce_19 = happySpecReduce_1 13# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn17 - ((:[]) happy_var_1 - )} - -happyReduce_20 = happySpecReduce_3 13# happyReduction_20 -happyReduction_20 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn17 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_21 = happySpecReduce_3 14# happyReduction_21 -happyReduction_21 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn18 - (UnifyProfile happy_var_2 - )} - -happyReduce_22 = happySpecReduce_1 14# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - happyIn18 - (ConstProfile happy_var_1 - )} - -happyReduce_23 = happySpecReduce_0 15# happyReduction_23 -happyReduction_23 = happyIn19 - ([] - ) - -happyReduce_24 = happySpecReduce_1 15# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn19 - ((:[]) happy_var_1 - )} - -happyReduce_25 = happySpecReduce_3 15# happyReduction_25 -happyReduction_25 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn19 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_26 = happySpecReduce_1 16# happyReduction_26 -happyReduction_26 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn20 - (CatS happy_var_1 - )} - -happyReduce_27 = happySpecReduce_1 16# happyReduction_27 -happyReduction_27 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn20 - (TermS happy_var_1 - )} - -happyReduce_28 = happySpecReduce_1 17# happyReduction_28 -happyReduction_28 happy_x_1 - = happyIn21 - ([] - ) - -happyReduce_29 = happySpecReduce_1 17# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn21 - ((:[]) happy_var_1 - )} - -happyReduce_30 = happySpecReduce_2 17# happyReduction_30 -happyReduction_30 happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut21 happy_x_2 of { happy_var_2 -> - happyIn21 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_31 = happySpecReduce_1 18# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn22 - (Category happy_var_1 - )} - -happyNewToken action sts stk [] = - happyDoAction 17# (error "reading EOF!") action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS ";") -> cont 1#; - PT _ (TS ":") -> cont 2#; - PT _ (TS ".") -> cont 3#; - PT _ (TS "->") -> cont 4#; - PT _ (TS "_") -> cont 5#; - PT _ (TS "[") -> cont 6#; - PT _ (TS "]") -> cont 7#; - PT _ (TS ",") -> cont 8#; - PT _ (TS "end") -> cont 9#; - PT _ (TS "grammar") -> cont 10#; - PT _ (TS "startcat") -> cont 11#; - PT _ (TV happy_dollar_dollar) -> cont 12#; - PT _ (TI happy_dollar_dollar) -> cont 13#; - PT _ (TL happy_dollar_dollar) -> cont 14#; - PT _ (T_SingleQuoteString happy_dollar_dollar) -> cont 15#; - _ -> cont 16#; - _ -> happyError' (tk:tks) - } - -happyError_ tk tks = happyError' (tk:tks) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = (thenM) -happyReturn :: () => a -> Err a -happyReturn = (returnM) -happyThen1 m k tks = (thenM) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (returnM) a -happyError' :: () => [Token] -> Err a -happyError' = happyError - -pGrammars tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut8 x)) - -happySeq = happyDontSeq - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) - -myLexer = tokens -{-# LINE 1 "GenericTemplate.hs" #-} --- $Id: ParCFG.hs,v 1.8 2005/05/17 14:04:37 bringert Exp $ - - - - - - - - - - - - - -{-# LINE 27 "GenericTemplate.hs" #-} - - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - - - - - - - - - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 169 "GenericTemplate.hs" #-} - - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/src-3.0/GF/CFGM/ParCFG.y b/src-3.0/GF/CFGM/ParCFG.y deleted file mode 100644 index 7b3041b3b..000000000 --- a/src-3.0/GF/CFGM/ParCFG.y +++ /dev/null @@ -1,129 +0,0 @@ --- This Happy file was machine-generated by the BNF converter -{ -module ParCFG where -import AbsCFG -import LexCFG -import ErrM -} - -%name pGrammars Grammars - --- no lexer declaration -%monad { Err } { thenM } { returnM } -%tokentype { Token } - -%token - ';' { PT _ (TS ";") } - ':' { PT _ (TS ":") } - '.' { PT _ (TS ".") } - '->' { PT _ (TS "->") } - '_' { PT _ (TS "_") } - '[' { PT _ (TS "[") } - ']' { PT _ (TS "]") } - ',' { PT _ (TS ",") } - 'end' { PT _ (TS "end") } - 'grammar' { PT _ (TS "grammar") } - 'startcat' { PT _ (TS "startcat") } - -L_ident { PT _ (TV $$) } -L_integ { PT _ (TI $$) } -L_quoted { PT _ (TL $$) } -L_SingleQuoteString { PT _ (T_SingleQuoteString $$) } -L_err { _ } - - -%% - -Ident :: { Ident } : L_ident { Ident $1 } -Integer :: { Integer } : L_integ { (read $1) :: Integer } -String :: { String } : L_quoted { $1 } -SingleQuoteString :: { SingleQuoteString} : L_SingleQuoteString { SingleQuoteString ($1)} - -Grammars :: { Grammars } -Grammars : ListGrammar { Grammars (reverse $1) } - - -Grammar :: { Grammar } -Grammar : 'grammar' Ident ListFlag ListRule 'end' 'grammar' { Grammar $2 (reverse $3) (reverse $4) } - - -ListGrammar :: { [Grammar] } -ListGrammar : {- empty -} { [] } - | ListGrammar Grammar { flip (:) $1 $2 } - - -Flag :: { Flag } -Flag : 'startcat' Category { StartCat $2 } - - -ListFlag :: { [Flag] } -ListFlag : {- empty -} { [] } - | ListFlag Flag ';' { flip (:) $1 $2 } - - -Rule :: { Rule } -Rule : Fun ':' Profiles '.' Category '->' ListSymbol { Rule $1 $3 $5 $7 } - - -ListRule :: { [Rule] } -ListRule : {- empty -} { [] } - | ListRule Rule ';' { flip (:) $1 $2 } - - -Fun :: { Fun } -Fun : Ident { Cons $1 } - | '_' { Coerce } - - -Profiles :: { Profiles } -Profiles : '[' ListProfile ']' { Profiles $2 } - - -ListProfile :: { [Profile] } -ListProfile : {- empty -} { [] } - | Profile { (:[]) $1 } - | Profile ',' ListProfile { (:) $1 $3 } - - -Profile :: { Profile } -Profile : '[' ListInteger ']' { UnifyProfile $2 } - | Ident { ConstProfile $1 } - - -ListInteger :: { [Integer] } -ListInteger : {- empty -} { [] } - | Integer { (:[]) $1 } - | Integer ',' ListInteger { (:) $1 $3 } - - -Symbol :: { Symbol } -Symbol : Category { CatS $1 } - | String { TermS $1 } - - -ListSymbol :: { [Symbol] } -ListSymbol : '.' { [] } - | Symbol { (:[]) $1 } - | Symbol ListSymbol { (:) $1 $2 } - - -Category :: { Category } -Category : SingleQuoteString { Category $1 } - - - -{ - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) - -myLexer = tokens -} - diff --git a/src-3.0/GF/CFGM/PrintCFG.hs b/src-3.0/GF/CFGM/PrintCFG.hs deleted file mode 100644 index 0fd46239c..000000000 --- a/src-3.0/GF/CFGM/PrintCFG.hs +++ /dev/null @@ -1,157 +0,0 @@ -module GF.CFGM.PrintCFG where - --- pretty-printer generated by the BNF converter - -import GF.CFGM.AbsCFG -import Char - --- the top-level printing method -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - "[" :ts -> showChar '[' . rend i ts - "(" :ts -> showChar '(' . rend i ts - "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts - "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts - "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts - ";" :ts -> showChar ';' . new i . rend i ts - t : "," :ts -> showString t . space "," . rend i ts - t : ")" :ts -> showString t . showChar ')' . rend i ts - t : "]" :ts -> showString t . showChar ']' . rend i ts - t :ts -> space t . rend i ts - _ -> id - new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace - space t = showString t . (\s -> if null s then "" else (' ':s)) - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- the printer class does the job -class Print a where - prt :: Int -> a -> Doc - prtList :: [a] -> Doc - prtList = concatD . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') - prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q s = case s of - _ | s == q -> showChar '\\' . showChar s - '\\'-> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - _ -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - -instance Print Double where - prt _ x = doc (shows x) - - -instance Print Ident where - prt _ (Ident i) = doc (showString i) - - -instance Print SingleQuoteString where - prt _ (SingleQuoteString i) = doc (showString i) - - - -instance Print Grammars where - prt i e = case e of - Grammars grammars -> prPrec i 0 (concatD [prt 0 grammars]) - - -instance Print Grammar where - prt i e = case e of - Grammar id flags rules -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 id , prt 0 flags , prt 0 rules , doc (showString "end") , doc (showString "grammar")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Flag where - prt i e = case e of - StartCat category -> prPrec i 0 (concatD [doc (showString "startcat") , prt 0 category]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Rule where - prt i e = case e of - Rule fun profiles category symbols -> prPrec i 0 (concatD [prt 0 fun , doc (showString ":") , prt 0 profiles , doc (showString ".") , prt 0 category , doc (showString "->") , prt 0 symbols]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Fun where - prt i e = case e of - Cons id -> prPrec i 0 (concatD [prt 0 id]) - Coerce -> prPrec i 0 (concatD [doc (showString "_")]) - - -instance Print Profiles where - prt i e = case e of - Profiles profiles -> prPrec i 0 (concatD [doc (showString "[") , prt 0 profiles , doc (showString "]")]) - - -instance Print Profile where - prt i e = case e of - UnifyProfile ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")]) - ConstProfile id -> prPrec i 0 (concatD [prt 0 id]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Symbol where - prt i e = case e of - CatS category -> prPrec i 0 (concatD [prt 0 category]) - TermS str -> prPrec i 0 (concatD [prt 0 str]) - - prtList es = case es of - [] -> (concatD [doc (showString ".")]) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Category where - prt i e = case e of - Category singlequotestring -> prPrec i 0 (concatD [prt 0 singlequotestring]) - - - diff --git a/src-3.0/GF/CFGM/PrintCFGrammar.hs b/src-3.0/GF/CFGM/PrintCFGrammar.hs deleted file mode 100644 index a68d2325c..000000000 --- a/src-3.0/GF/CFGM/PrintCFGrammar.hs +++ /dev/null @@ -1,113 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrintCFGrammar --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/17 14:04:38 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.20 $ --- --- Handles printing a CFGrammar in CFGM format. ------------------------------------------------------------------------------ - -module GF.CFGM.PrintCFGrammar (prCanonAsCFGM) where - -import GF.Canon.AbsGFC -import qualified GF.CFGM.PrintCFG as PrintCFG -import GF.Infra.Ident -import GF.Canon.GFC -import GF.Infra.Modules - -import qualified GF.Conversion.GFC as Cnv -import GF.Infra.Print (prt) -import GF.Formalism.CFG (CFRule(..)) -import qualified GF.Formalism.Utilities as GU -import qualified GF.Conversion.Types as GT -import qualified GF.CFGM.AbsCFG as AbsCFG -import GF.Formalism.Utilities (Symbol(..)) - -import GF.Data.ErrM -import GF.Data.Utilities (compareBy) -import qualified GF.Infra.Option as Option - -import Data.List (intersperse, sortBy) -import Data.Maybe (listToMaybe, maybeToList, maybe) - -import GF.Infra.Print -import GF.System.Tracing - --- | FIXME: should add an Options argument, --- to be able to decide which CFG conversion one wants to use -prCanonAsCFGM :: Option.Options -> CanonGrammar -> String -prCanonAsCFGM opts gr = unlines $ map (prLangAsCFGM gr) xs - where - cncs = maybe [] (allConcretes gr) (greatestAbstract gr) - cncms = map (\i -> (i,fromOk (lookupModule gr i))) cncs - fromOk (Ok x) = x - fromOk (Bad y) = error y - xs = tracePrt "CFGM languages" (prtBefore "\n") - [ (i, getFlag fs "startcat", getFlag fs "conversion") | - (i, ModMod (Module{flags=fs})) <- cncms ] - --- | FIXME: need to look in abstract module too -getFlag :: [Flag] -> String -> Maybe String -getFlag fs x = listToMaybe [v | Flg (IC k) (IC v) <- fs, k == x] - --- FIXME: (1) Should use 'ShellState.stateCFG' --- instead of 'Cnv.gfc2cfg' (which recalculates the grammar every time) --- --- FIXME: (2) Should use the state options, when calculating the CFG --- (this is solved automatically if one solves (1) above) -prLangAsCFGM :: CanonGrammar -> (Ident, Maybe String, Maybe String) -> String -prLangAsCFGM gr (i, start, cnv) = prCFGrammarAsCFGM (Cnv.gfc2cfg opts (gr, i)) i start --- prLangAsCFGM gr i start = prCFGrammarAsCFGM (Cnv.cfg (Cnv.pInfo opts gr i)) i start - where opts = Option.Opts $ maybeToList $ fmap Option.gfcConversion cnv - -prCFGrammarAsCFGM :: GT.CGrammar -> Ident -> Maybe String -> String -prCFGrammarAsCFGM gr i start = PrintCFG.printTree $ cfGrammarToCFGM gr i start - -cfGrammarToCFGM :: GT.CGrammar -> Ident -> Maybe String -> AbsCFG.Grammar -cfGrammarToCFGM gr i start = - AbsCFG.Grammar (identToCFGMIdent i) flags $ sortCFGMRules $ map ruleToCFGMRule gr - where flags = maybe [] (\c -> [AbsCFG.StartCat $ strToCFGMCat (c++"{}.s")]) start - sortCFGMRules = sortBy (compareBy ruleKey) - ruleKey (AbsCFG.Rule f ps cat rhs) = (cat,f) - -ruleToCFGMRule :: GT.CRule -> AbsCFG.Rule -ruleToCFGMRule (CFRule c rhs (GU.Name fun profile)) - = AbsCFG.Rule fun' p' c' rhs' - where - fun' = identToFun fun - p' = profileToCFGMProfile profile - c' = catToCFGMCat c - rhs' = map symbolToGFCMSymbol rhs - -profileToCFGMProfile :: [GU.Profile (GU.SyntaxForest GT.Fun)] -> AbsCFG.Profiles -profileToCFGMProfile = AbsCFG.Profiles . map cnvProfile - where cnvProfile (GU.Unify ns) = AbsCFG.UnifyProfile $ map fromIntegral ns - -- FIXME: is it always FNode? - cnvProfile (GU.Constant (GU.FNode c _)) = AbsCFG.ConstProfile $ identToCFGMIdent c - - -identToCFGMIdent :: Ident -> AbsCFG.Ident -identToCFGMIdent = AbsCFG.Ident . prt - -identToFun :: Ident -> AbsCFG.Fun -identToFun IW = AbsCFG.Coerce -identToFun i = AbsCFG.Cons (identToCFGMIdent i) - -strToCFGMCat :: String -> AbsCFG.Category -strToCFGMCat = AbsCFG.Category . AbsCFG.SingleQuoteString . quoteSingle - -catToCFGMCat :: GT.CCat -> AbsCFG.Category -catToCFGMCat = strToCFGMCat . prt - -symbolToGFCMSymbol :: Symbol GT.CCat GT.Token -> AbsCFG.Symbol -symbolToGFCMSymbol (Cat c) = AbsCFG.CatS (catToCFGMCat c) -symbolToGFCMSymbol (Tok t) = AbsCFG.TermS (prt t) - -quoteSingle :: String -> String -quoteSingle s = "'" ++ escapeSingle s ++ "'" - where escapeSingle = concatMap (\c -> if c == '\'' then "\\'" else [c]) diff --git a/src-3.0/GF/Canon/AbsGFC.hs b/src-3.0/GF/Canon/AbsGFC.hs deleted file mode 100644 index 8ce719104..000000000 --- a/src-3.0/GF/Canon/AbsGFC.hs +++ /dev/null @@ -1,182 +0,0 @@ -module GF.Canon.AbsGFC where - -import GF.Infra.Ident --H - --- Haskell module generated by the BNF converter, except --H - --- newtype Ident = Ident String deriving (Eq,Ord,Show) --H - -data Canon = - MGr [Ident] Ident [Module] - | Gr [Module] - deriving (Eq,Ord,Show) - -data Line = - LMulti [Ident] Ident - | LHeader ModType Extend Open - | LFlag Flag - | LDef Def - | LEnd - deriving (Eq,Ord,Show) - -data Module = - Mod ModType Extend Open [Flag] [Def] - deriving (Eq,Ord,Show) - -data ModType = - MTAbs Ident - | MTCnc Ident Ident - | MTRes Ident - | MTTrans Ident Ident Ident - deriving (Eq,Ord,Show) - -data Extend = - Ext [Ident] - | NoExt - deriving (Eq,Ord,Show) - -data Open = - Opens [Ident] - | NoOpens - deriving (Eq,Ord,Show) - -data Flag = - Flg Ident Ident - deriving (Eq,Ord,Show) - -data Def = - AbsDCat Ident [Decl] [CIdent] - | AbsDFun Ident Exp Exp - | AbsDTrans Ident Exp - | ResDPar Ident [ParDef] - | ResDOper Ident CType Term - | CncDCat Ident CType Term Term - | CncDFun Ident CIdent [ArgVar] Term Term - | AnyDInd Ident Status Ident - deriving (Eq,Ord,Show) - -data ParDef = - ParD Ident [CType] - deriving (Eq,Ord,Show) - -data Status = - Canon - | NonCan - deriving (Eq,Ord,Show) - -data CIdent = - CIQ Ident Ident - deriving (Eq,Ord,Show) - -data Exp = - EApp Exp Exp - | EProd Ident Exp Exp - | EAbs Ident Exp - | EAtom Atom - | EData - | EEq [Equation] - deriving (Eq,Ord,Show) - -data Sort = - SType - deriving (Eq,Ord,Show) - -data Equation = - Equ [APatt] Exp - deriving (Eq,Ord,Show) - -data APatt = - APC CIdent [APatt] - | APV Ident - | APS String - | API Integer - | APF Double - | APW - deriving (Eq,Ord,Show) - -data Atom = - AC CIdent - | AD CIdent - | AV Ident - | AM Integer - | AS String - | AI Integer - | AF Double - | AT Sort - deriving (Eq,Ord,Show) - -data Decl = - Decl Ident Exp - deriving (Eq,Ord,Show) - -data CType = - RecType [Labelling] - | Table CType CType - | Cn CIdent - | TStr - | TInts Integer - deriving (Eq,Ord,Show) - -data Labelling = - Lbg Label CType - deriving (Eq,Ord,Show) - -data Term = - Arg ArgVar - | I CIdent - | Par CIdent [Term] - | LI Ident - | R [Assign] - | P Term Label - | T CType [Case] - | V CType [Term] - | S Term Term - | C Term Term - | FV [Term] - | EInt Integer - | EFloat Double - | K Tokn - | E - deriving (Eq,Ord,Show) - -data Tokn = - KS String - | KP [String] [Variant] - | KM String - deriving (Eq,Ord,Show) - -data Assign = - Ass Label Term - deriving (Eq,Ord,Show) - -data Case = - Cas [Patt] Term - deriving (Eq,Ord,Show) - -data Variant = - Var [String] [String] - deriving (Eq,Ord,Show) - -data Label = - L Ident - | LV Integer - deriving (Eq,Ord,Show) - -data ArgVar = - A Ident Integer - | AB Ident Integer Integer - deriving (Eq,Ord,Show) - -data Patt = - PC CIdent [Patt] - | PV Ident - | PW - | PR [PattAssign] - | PI Integer - | PF Double - deriving (Eq,Ord,Show) - -data PattAssign = - PAss Label Patt - deriving (Eq,Ord,Show) - diff --git a/src-3.0/GF/Canon/AbsToBNF.hs b/src-3.0/GF/Canon/AbsToBNF.hs deleted file mode 100644 index e30e836da..000000000 --- a/src-3.0/GF/Canon/AbsToBNF.hs +++ /dev/null @@ -1,38 +0,0 @@ -module GF.Canon.AbsToBNF where - -import GF.Grammar.SGrammar -import GF.Data.Operations -import GF.Infra.Option -import GF.Canon.GFC (CanonGrammar) - --- AR 10/5/2007 - -abstract2bnf :: CanonGrammar -> String -abstract2bnf = sgrammar2bnf . gr2sgr noOptions emptyProbs - -sgrammar2bnf :: SGrammar -> String -sgrammar2bnf = unlines . map (prBNFRule . mkBNF) . allRules - -prBNFRule :: BNFRule -> String -prBNFRule = id - -type BNFRule = String - -mkBNF :: SRule -> BNFRule -mkBNF (pfun,(args,cat)) = - fun ++ "." +++ gfId cat +++ "::=" +++ rhs +++ ";" - where - fun = gfId (snd pfun) - rhs = case args of - [] -> prQuotedString (snd pfun) - _ -> unwords (map gfId args) - --- good for GF -gfId i = i - --- good for BNFC -gfIdd i = case i of - "Int" -> "Integer" - "String" -> i - "Float" -> "Double" - _ -> "G" ++ i ++ "_" diff --git a/src-3.0/GF/Canon/CMacros.hs b/src-3.0/GF/Canon/CMacros.hs deleted file mode 100644 index 572f09763..000000000 --- a/src-3.0/GF/Canon/CMacros.hs +++ /dev/null @@ -1,334 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CMacros --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.29 $ --- --- Macros for building and analysing terms in GFC concrete syntax. --- --- macros for concrete syntax in GFC that do not need lookup in a grammar ------------------------------------------------------------------------------ - -module GF.Canon.CMacros where - -import GF.Infra.Ident -import GF.Canon.AbsGFC -import GF.Canon.GFC -import qualified GF.Infra.Ident as A ---- no need to qualif? 21/9 -import qualified GF.Grammar.Values as V -import qualified GF.Grammar.MMacros as M -import GF.Grammar.PrGrammar -import GF.Data.Str - -import GF.Data.Operations - -import Data.Char -import Control.Monad - --- | how to mark subtrees, dep. on node, position, whether focus -type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String) - --- | also to process the text (needed for escapes e.g. in XML) -type Marker = (JustMarker, Maybe (String -> String)) - -defTMarker :: JustMarker -> Marker -defTMarker = flip (curry id) Nothing - -markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term -markSubtree (mk,esc) n is = markSubterm esc . mk n is - -escapeMkString :: Marker -> Maybe (String -> String) -escapeMkString = snd - --- | if no marking is wanted, use the following -noMark :: Marker -noMark = defTMarker mk where - mk _ _ _ = ("","") - --- | mark metas with their categories -metaCatMark :: Marker -metaCatMark = defTMarker mk where - mk nod _ _ = case nod of - V.N (_,V.AtM _,val,_,_) -> ("", '+':prt val) - _ -> ("","") - --- | for vanilla brackets, focus, and position, use -markBracket :: Marker -markBracket = defTMarker mk where - mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]") - --- | for focus only -markFocus :: Marker -markFocus = defTMarker mk where - mk n p b = if b then ("[*","*]") else ("","") - --- | for XML, use -markJustXML :: JustMarker -markJustXML n i b = - if b - then ("", "") - else ("", "") - where - c = "type=" ++ prt (M.valNode n) - p = "position=" ++ (show $ reverse i) - s = if (null (M.constrsNode n)) then "" else " status=incorrect" - -markXML :: Marker -markXML = (markJustXML, Just esc) where - esc s = case s of - '\\':'<':cs -> '\\':'<':esc cs - '\\':'>':cs -> '\\':'>':esc cs - '\\':'\\':cs -> '\\':'\\':esc cs - ----- the first 3 needed because marking may revisit; needs to be fixed - - '<':cs -> '\\':'<':esc cs - '>':cs -> '\\':'>':esc cs - '\\':cs -> '\\':'\\':esc cs - c :cs -> c :esc cs - _ -> s - --- | for XML in JGF 1, use -markXMLjgf :: Marker -markXMLjgf = defTMarker mk where - mk n p b = - if b - then ("", "") - else ("","") - where - c = "type=" ++ prt (M.valNode n) - --- | the marking engine -markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term -markSubterm esc (beg, end) t = case t of - R rs -> R $ map markField rs - T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs] - FV ts -> FV $ map mark ts - _ -> foldr1 C (tm beg ++ [mkEscIf t] ++ tm end) -- t : Str guaranteed? - where - mark = markSubterm esc (beg, end) - markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt - tm s = if null s then [] else [tM s] - mkEscIf t = case esc of - Just f -> mkEsc f t - _ -> t - mkEsc f t = case t of - K (KS s) -> K (KS (f s)) - C u v -> C (mkEsc f u) (mkEsc f v) - FV ts -> FV (map (mkEsc f) ts) - _ -> t ---- do we need to look at other cases? - -tK,tM :: String -> Term -tK = K . KS -tM = K . KM - -term2patt :: Term -> Err Patt -term2patt trm = case trm of - Par c aa -> do - aa' <- mapM term2patt aa - return (PC c aa') - R r -> do - let (ll,aa) = unzip [(l,a) | Ass l a <- r] - aa' <- mapM term2patt aa - return (PR (map (uncurry PAss) (zip ll aa'))) - LI x -> return $ PV x - EInt i -> return $ PI i - EFloat i -> return $ PF i - FV (t:_) -> term2patt t ---- - _ -> prtBad "no pattern corresponds to term" trm - -patt2term :: Patt -> Term -patt2term p = case p of - PC x ps -> Par x (map patt2term ps) - PV x -> LI x - PW -> anyTerm ---- - PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ] - PI i -> EInt i - PF i -> EFloat i - -anyTerm :: Term -anyTerm = LI (A.identC "_") --- should not happen - -matchPatt :: [Case] -> Term -> Err Term -matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts -matchPatt cs0 trm = term2patt trm >>= match cs0 where - match cs t = - case cs of - Cas ps b :_ | elem t ps -> return b - _:cs' -> match cs' t - [] -> Bad $ "pattern not found for" +++ prt t - +++ "among" ++++ unlines (map prt cs0) ---- debug - -defLinType :: CType -defLinType = RecType [Lbg (L (A.identC "s")) TStr] - -defLindef :: Term -defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))] - -isDiscontinuousCType :: CType -> Bool -isDiscontinuousCType t = case t of - RecType rs -> length [t | Lbg _ t <- rs, valTableType t == TStr] > 1 - _ -> True --- does not occur; would not behave well in lin commands - -valTableType :: CType -> CType -valTableType t = case t of - Table _ v -> valTableType v - _ -> t - -strsFromTerm :: Term -> Err [Str] -strsFromTerm t = case t of - K (KS s) -> return [str s] - K (KM s) -> return [str s] - K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]] - C s t -> do - s' <- strsFromTerm s - t' <- strsFromTerm t - return [plusStr x y | x <- s', y <- t'] - FV ts -> liftM concat $ mapM strsFromTerm ts - E -> return [str []] - _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug ----- _ -> prtBad "cannot get Str from term " t - --- | recursively collect all branches in a table -allInTable :: Term -> [Term] -allInTable t = case t of - T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ? - _ -> [t] - --- | to gather s-fields; assumes term in normal form, preserves label -allLinFields :: Term -> Err [[(Label,Term)]] -allLinFields trm = case trm of ----- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good - R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad - FV ts -> do - lts <- mapM allLinFields ts - return $ concat lts - - T _ ts -> liftM concat $ mapM allLinFields [t | Cas _ t <- ts] - V _ ts -> liftM concat $ mapM allLinFields ts - S t _ -> allLinFields t - - _ -> prtBad "fields can only be sought in a record not in" trm - --- | deprecated -isLinLabel :: Label -> Bool -isLinLabel l = case l of - L (A.IC ('s':cs)) | all isDigit cs -> True - -- peb (28/4-04), for MCFG grammars to work: - L (A.IC cs) | null cs || head cs `elem` ".!" -> True - _ -> False - --- | to gather ultimate cases in a table; preserves pattern list -allCaseValues :: Term -> [([Patt],Term)] -allCaseValues trm = case trm of - T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0] - _ -> [([],trm)] - --- | to gather all linearizations; assumes normal form, preserves label and args -allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] -allLinValues trm = do - lts <- allLinFields trm - mapM (mapPairsM (return . allCaseValues)) lts - --- | to gather all fields; does not assume s naming of fields; --- used in Morpho only -allAllLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] -allAllLinValues trm = do - lts <- allFields trm - mapM (mapPairsM (return . allCaseValues)) lts - where - allFields trm = case trm of - R rs -> return [[(l,t) | Ass l t <- rs]] - FV ts -> do - lts <- mapM allFields ts - return $ concat lts - _ -> prtBad "fields can only be sought in a record not in" trm - --- | to gather all linearizations, even from nested records; params ignored -allLinBranches :: Term -> [([Label],Term)] -allLinBranches trm = case trm of - R rs -> [(l:ls,u) | Ass l t <- rs, (ls,u) <- allLinBranches t] - FV ts -> concatMap allLinBranches ts - T _ ts -> concatMap allLinBranches [t | Cas _ t <- ts] - V _ ts -> concatMap allLinBranches ts - _ -> [([],trm)] - -redirectIdent :: A.Ident -> CIdent -> CIdent -redirectIdent n f@(CIQ _ c) = CIQ n c - -ciq :: A.Ident -> A.Ident -> CIdent -ciq n f = CIQ n f - -wordsInTerm :: Term -> [String] -wordsInTerm trm = filter (not . null) $ case trm of - K (KS s) -> [s] - S c _ -> wo c - R rs -> concat [wo t | Ass _ t <- rs] - T _ cs -> concat [wo t | Cas _ t <- cs] - V _ cs -> concat [wo t | t <- cs] - C s t -> wo s ++ wo t - FV ts -> concatMap wo ts - K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs] - P t _ -> wo t --- not needed ? - _ -> [] - where wo = wordsInTerm - -onTokens :: (String -> String) -> Term -> Term -onTokens f t = case t of - K (KS s) -> K (KS (f s)) - K (KP ss vs) -> K (KP (map f ss) [Var (map f x) (map f y) | Var x y <- vs]) - _ -> composSafeOp (onTokens f) t - --- | to define compositional term functions -composSafeOp :: (Term -> Term) -> Term -> Term -composSafeOp op trm = case composOp (mkMonadic op) trm of - Ok t -> t - _ -> error "the operation is safe isn't it ?" - where - mkMonadic f = return . f - --- | to define compositional term functions -composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp co trm = - case trm of - Par x as -> - do - as' <- mapM co as - return (Par x as') - R as -> - do - let onAss (Ass l t) = liftM (Ass l) (co t) - as' <- mapM onAss as - return (R as') - P a x -> - do - a' <- co a - return (P a' x) - T x as -> - do - let onCas (Cas ps t) = liftM (Cas ps) (co t) - as' <- mapM onCas as - return (T x as') - S a b -> - do - a' <- co a - b' <- co b - return (S a' b') - C a b -> - do - a' <- co a - b' <- co b - return (C a' b') - FV as -> - do - as' <- mapM co as - return (FV as') - V x as -> - do - as' <- mapM co as - return (V x as') - _ -> return trm -- covers Arg, I, LI, K, E diff --git a/src-3.0/GF/Canon/CanonToGFCC.hs b/src-3.0/GF/Canon/CanonToGFCC.hs deleted file mode 100644 index 044ea3669..000000000 --- a/src-3.0/GF/Canon/CanonToGFCC.hs +++ /dev/null @@ -1,45 +0,0 @@ -module GF.Canon.CanonToGFCC where - -import GF.Devel.GrammarToGFCC -import GF.Devel.PrintGFCC -import GF.GFCC.CheckGFCC (checkGFCCmaybe) -import GF.GFCC.OptimizeGFCC -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.CanonToGrammar -import GF.Canon.Subexpressions -import GF.Devel.PrintGFCC -import GF.Grammar.PrGrammar - -import qualified GF.Infra.Modules as M -import GF.Infra.Option - -import GF.Data.Operations -import GF.Text.UTF8 - -canon2gfccPr opts = printGFCC . canon2gfcc opts -canon2gfcc opts = source2gfcc opts . canon2source ---- -canon2source = err error id . canon2sourceGrammar . unSubelimCanon - -source2gfcc opts gf = - let - (abs,gfcc) = mkCanon2gfcc opts (gfcabs gf) gf - gfcc1 = maybe undefined id $ checkGFCCmaybe gfcc - in addParsers $ if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1 - -gfcabs gfc = - prt $ head $ M.allConcretes gfc $ maybe (error "no abstract") id $ - M.greatestAbstract gfc - -{- --- this variant makes utf8 conversion; used in back ends -mkCanon2gfcc :: CanonGrammar -> D.GFCC -mkCanon2gfcc = --- canon2gfcc . reorder abs . utf8Conv . canon2canon abs - optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize - --- this variant makes no utf8 conversion; used in ShellState -mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC -mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize --} - diff --git a/src-3.0/GF/Canon/CanonToGrammar.hs b/src-3.0/GF/Canon/CanonToGrammar.hs deleted file mode 100644 index 078c3cc03..000000000 --- a/src-3.0/GF/Canon/CanonToGrammar.hs +++ /dev/null @@ -1,203 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CanonToGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:17 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.15 $ --- --- a decompiler. AR 12/6/2003 -- 19/4/2004 ------------------------------------------------------------------------------ - -module GF.Canon.CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where - -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.MkGFC ----import CMacros -import qualified GF.Infra.Modules as M -import qualified GF.Infra.Option as O -import qualified GF.Grammar.Grammar as G -import qualified GF.Grammar.Macros as F - -import GF.Infra.Ident -import GF.Data.Operations - -import Control.Monad - -canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar -canon2sourceGrammar gr = do - ms' <- mapM canon2sourceModule $ M.modules gr - return $ M.MGrammar ms' - -canon2sourceModule :: CanonModule -> Err G.SourceModule -canon2sourceModule (i,mi) = do - i' <- redIdent i - info' <- case mi of - M.ModMod m -> do - (e,os) <- redExtOpen m - flags <- mapM redFlag $ M.flags m - (abstr,mt) <- case M.mtype m of - M.MTConcrete a -> do - a' <- redIdent a - return (a', M.MTConcrete a') - M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed - M.MTResource -> return (i',M.MTResource) --- c' not needed - M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed - defs <- mapMTree redInfo $ M.jments m - return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs - _ -> Bad $ "cannot decompile module type" - return (i',info') - where - redExtOpen m = do - e' <- return $ M.extend m - os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $ - M.opens m - return (e',os') - -redInfo :: (Ident,Info) -> Err (Ident,G.Info) -redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do - c' <- redIdent c - info' <- case info of - AbsCat cont fs -> do - return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs)) - AbsFun typ df -> do - return $ G.AbsFun (Yes typ) (Yes df) - AbsTrans t -> do - return $ G.AbsTrans t - - ResPar par -> do - par' <- mapM redParam par - return $ G.ResParam (Yes (par',Nothing)) ---- list of values - - ResOper pty ptr -> do - ty' <- redCType pty - trm' <- redCTerm ptr - return $ G.ResOper (Yes ty') (Yes trm') - - CncCat pty ptr ppr -> do - ty' <- redCType pty - trm' <- redCTerm ptr - ppr' <- redCTerm ppr - return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr') - CncFun (CIQ abstr cat) xx body ppr -> do - xx' <- mapM redArgVar xx - body' <- redCTerm body - ppr' <- redCTerm ppr - cat' <- redIdent cat - return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing - (Yes (F.mkAbs xx' body')) (Yes ppr') - - AnyInd b c -> liftM (G.AnyInd b) $ redIdent c - - return (c',info') - -redQIdent :: CIdent -> Err G.QIdent -redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c) - -redIdent :: Ident -> Err Ident -redIdent = return - -redFlag :: Flag -> Err O.Option -redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x]) - -redDecl :: Decl -> Err G.Decl -redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a) - -redType :: Exp -> Err G.Type -redType = redTerm - -redTerm :: Exp -> Err G.Term -redTerm t = return $ trExp t - --- resource - -redParam (ParD c cont) = do - c' <- redIdent c - cont' <- mapM redCType cont - return $ (c', [(IW,t) | t <- cont']) - --- concrete syntax - -redCType :: CType -> Err G.Type -redCType t = case t of - RecType lbs -> do - let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs] - ls' = map redLabel ls - ts' <- mapM redCType ts - return $ G.RecType $ zip ls' ts' - Table p v -> liftM2 G.Table (redCType p) (redCType v) - Cn mc -> liftM (uncurry G.QC) $ redQIdent mc - TStr -> return $ F.typeStr - TInts i -> return $ F.typeInts (fromInteger i) - -redCTerm :: Term -> Err G.Term -redCTerm x = case x of - Arg argvar -> liftM G.Vr $ redArgVar argvar - I cident -> liftM (uncurry G.Q) $ redQIdent cident - Par cident terms -> liftM2 F.mkApp - (liftM (uncurry G.QC) $ redQIdent cident) - (mapM redCTerm terms) - LI id -> liftM G.Vr $ redIdent id - R assigns -> do - let (ls,ts) = unzip [(l,t) | Ass l t <- assigns] - let ls' = map redLabel ls - ts' <- mapM redCTerm ts - return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts'] - P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label) - T ctype cases -> do - ctype' <- redCType ctype - let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases] - ps' <- mapM redPatt ps - ts' <- mapM redCTerm ts - let tinfo = case ps' of - [G.PV _] -> G.TTyped ctype' - _ -> G.TComp ctype' - return $ G.T tinfo $ zip ps' ts' - V ctype ts -> do - ctype' <- redCType ctype - ts' <- mapM redCTerm ts - return $ G.V ctype' ts' - S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term) - C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term) - FV terms -> liftM G.FV $ mapM redCTerm terms - K (KS str) -> return $ G.K str - EInt i -> return $ G.EInt i - EFloat i -> return $ G.EFloat i - E -> return $ G.Empty - K (KP d vs) -> return $ - G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs]) - where - tList ss = case ss of --- this should be in Macros - [] -> G.Empty - _ -> foldr1 G.C $ map G.K ss - -failure x = Bad $ "not yet" +++ show x ---- - -redArgVar :: ArgVar -> Err Ident -redArgVar x = case x of - A x i -> return $ IA (prIdent x, fromInteger i) - AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i) - -redLabel :: Label -> G.Label -redLabel (L x) = G.LIdent $ prIdent x -redLabel (LV i) = G.LVar $ fromInteger i - -redPatt :: Patt -> Err G.Patt -redPatt p = case p of - PV x -> liftM G.PV $ redIdent x - PC mc ps -> do - (m,c) <- redQIdent mc - liftM (G.PP m c) (mapM redPatt ps) - PR rs -> do - let (ls,ts) = unzip [(l,t) | PAss l t <- rs] - ls' = map redLabel ls - ts <- mapM redPatt ts - return $ G.PR $ zip ls' ts - PI i -> return $ G.PInt i - PF i -> return $ G.PFloat i - _ -> Bad $ "cannot recompile pattern" +++ show p - diff --git a/src-3.0/GF/Canon/GFC.cf b/src-3.0/GF/Canon/GFC.cf deleted file mode 100644 index d9385a49f..000000000 --- a/src-3.0/GF/Canon/GFC.cf +++ /dev/null @@ -1,170 +0,0 @@ --- top-level grammar - --- Canonical GF. AR 27/4/2003 - -entrypoints Canon, Line ; - --- old approach: read in a whole grammar - -MGr. Canon ::= "grammar" [Ident] "of" Ident ";" [Module] ; -Gr. Canon ::= [Module] ; - --- new approach: read line by line - -LMulti. Line ::= "grammar" [Ident] "of" Ident ";" ; -LHeader. Line ::= ModType "=" Extend Open "{" ; -LFlag. Line ::= Flag ";" ; -LDef. Line ::= Def ";" ; -LEnd. Line ::= "}" ; - -Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ; - -MTAbs. ModType ::= "abstract" Ident ; -MTCnc. ModType ::= "concrete" Ident "of" Ident ; -MTRes. ModType ::= "resource" Ident ; -MTTrans. ModType ::= "transfer" Ident ":" Ident "->" Ident ; - -separator Module "" ; - -Ext. Extend ::= [Ident] "**" ; -NoExt. Extend ::= ; - -Opens. Open ::= "open" [Ident] "in" ; -NoOpens. Open ::= ; - - --- judgements - -Flg. Flag ::= "flags" Ident "=" Ident ; --- to have the same res word as in GF - -AbsDCat. Def ::= "cat" Ident "[" [Decl] "]" "=" [CIdent] ; -AbsDFun. Def ::= "fun" Ident ":" Exp "=" Exp ; -AbsDTrans. Def ::= "transfer" Ident "=" Exp ; - -ResDPar. Def ::= "param" Ident "=" [ParDef] ; -ResDOper. Def ::= "oper" Ident ":" CType "=" Term ; - -CncDCat. Def ::= "lincat" Ident "=" CType "=" Term ";" Term ; -CncDFun. Def ::= "lin" Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ; - -AnyDInd. Def ::= Ident Status "in" Ident ; - -ParD. ParDef ::= Ident [CType] ; - --- the canonicity of an indirected constant - -Canon. Status ::= "data" ; -NonCan. Status ::= ; - --- names originating from resource modules: prefixed by the module name - -CIQ. CIdent ::= Ident "." Ident ; - --- types and terms in abstract syntax; no longer type-annotated - -EApp. Exp1 ::= Exp1 Exp2 ; -EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ; -EAbs. Exp ::= "\\" Ident "->" Exp ; -EAtom. Exp2 ::= Atom ; -EData. Exp2 ::= "data" ; - -EEq. Exp ::= "{" [Equation] "}" ; -- list of pattern eqs; primitive notion: [] - -coercions Exp 2 ; - -SType. Sort ::= "Type" ; - -Equ. Equation ::= [APatt] "->" Exp ; - -APC. APatt ::= "(" CIdent [APatt] ")" ; -APV. APatt ::= Ident ; -APS. APatt ::= String ; -API. APatt ::= Integer ; -APF. APatt ::= Double ; -APW. APatt ::= "_" ; - -separator Decl ";" ; -terminator APatt "" ; -terminator Equation ";" ; - -AC. Atom ::= CIdent ; -AD. Atom ::= "<" CIdent ">" ; -AV. Atom ::= "$" Ident ; -AM. Atom ::= "?" Integer ; -AS. Atom ::= String ; -AI. Atom ::= Integer ; -AT. Atom ::= Sort ; - -Decl. Decl ::= Ident ":" Exp ; - - --- types, terms, and patterns in concrete syntax - -RecType. CType ::= "{" [Labelling] "}" ; -Table. CType ::= "(" CType "=>" CType ")" ; -Cn. CType ::= CIdent ; -TStr. CType ::= "Str" ; -TInts. CType ::= "Ints" Integer ; - -Lbg. Labelling ::= Label ":" CType ; - -Arg. Term2 ::= ArgVar ; -I. Term2 ::= CIdent ; -- from resources -Par. Term2 ::= "<" CIdent [Term2] ">" ; -LI. Term2 ::= "$" Ident ; -- from pattern variables - -R. Term2 ::= "{" [Assign] "}" ; -P. Term1 ::= Term2 "." Label ; -T. Term1 ::= "table" CType "{" [Case] "}" ; -V. Term1 ::= "table" CType "[" [Term2] "]" ; -S. Term1 ::= Term1 "!" Term2 ; -C. Term ::= Term "++" Term1 ; -FV. Term1 ::= "variants" "{" [Term2] "}" ; --- no separator! - -EInt. Term2 ::= Integer ; -EFloat. Term2 ::= Double ; -K. Term2 ::= Tokn ; -E. Term2 ::= "[" "]" ; - -KS. Tokn ::= String ; -KP. Tokn ::= "[" "pre" [String] "{" [Variant] "}" "]" ; -internal KM. Tokn ::= String ; -- mark-up - -Ass. Assign ::= Label "=" Term ; -Cas. Case ::= [Patt] "=>" Term ; -Var. Variant ::= [String] "/" [String] ; - -coercions Term 2 ; - -L. Label ::= Ident ; -LV. Label ::= "$" Integer ; -A. ArgVar ::= Ident "@" Integer ; -- no bindings -AB. ArgVar ::= Ident "+" Integer "@" Integer ; -- with a number of bindings - -PC. Patt ::= "(" CIdent [Patt] ")" ; -PV. Patt ::= Ident ; -PW. Patt ::= "_" ; -PR. Patt ::= "{" [PattAssign] "}" ; -PI. Patt ::= Integer ; -PF. Patt ::= Double ; - -PAss. PattAssign ::= Label "=" Patt ; - ---- here we use the new pragmas to generate list rules - -terminator Flag ";" ; -terminator Def ";" ; -separator ParDef "|" ; -separator CType "" ; -separator CIdent "" ; -separator Assign ";" ; -separator ArgVar "," ; -separator Labelling ";" ; -separator Case ";" ; -separator Term2 "" ; -separator String "" ; -separator Variant ";" ; -separator PattAssign ";" ; -separator Patt "" ; -separator Ident "," ; - diff --git a/src-3.0/GF/Canon/GFC.hs b/src-3.0/GF/Canon/GFC.hs deleted file mode 100644 index 9e93835f7..000000000 --- a/src-3.0/GF/Canon/GFC.hs +++ /dev/null @@ -1,104 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:22 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.12 $ --- --- canonical GF. AR 10\/9\/2002 -- 9\/5\/2003 -- 21\/9 ------------------------------------------------------------------------------ - -module GF.Canon.GFC (Context, - CanonGrammar, - CanonModInfo, - CanonModule, - CanonAbs, - Info(..), - Printname, - prPrintnamesGrammar, - mapInfoTerms, - setFlag, - flagIncomplete, - isIncompleteCanon, - hasFlagCanon, - flagCanon - ) where - -import GF.Canon.AbsGFC -import GF.Canon.PrintGFC -import qualified GF.Grammar.Abstract as A - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Zipper -import GF.Data.Operations -import qualified GF.Infra.Modules as M - -import Data.Char -import qualified Data.ByteString.Char8 as BS -import Control.Arrow (first) - -type Context = [(Ident,Exp)] - -type CanonGrammar = M.MGrammar Ident Flag Info - -type CanonModInfo = M.ModInfo Ident Flag Info - -type CanonModule = (Ident, CanonModInfo) - -type CanonAbs = M.Module Ident Option Info - -data Info = - AbsCat A.Context [A.Fun] - | AbsFun A.Type A.Term - | AbsTrans A.Term - - | ResPar [ParDef] - | ResOper CType Term -- ^ global constant - | CncCat CType Term Printname - | CncFun CIdent [ArgVar] Term Printname - | AnyInd Bool Ident - deriving (Show) - -type Printname = Term - -mapInfoTerms :: (Term -> Term) -> Info -> Info -mapInfoTerms f i = case i of - ResOper x a -> ResOper x (f a) - CncCat x a y -> CncCat x (f a) y - CncFun x y a z -> CncFun x y (f a) z - _ -> i - -setFlag :: String -> String -> [Flag] -> [Flag] -setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= BS.pack n] - -flagIncomplete :: Flag -flagIncomplete = flagCanon "incomplete" "true" - -isIncompleteCanon :: CanonModule -> Bool -isIncompleteCanon = hasFlagCanon flagIncomplete - -hasFlagCanon :: Flag -> CanonModule -> Bool -hasFlagCanon f (_,M.ModMod mo) = elem f $ M.flags mo -hasFlagCanon f _ = True ---- safe, useless - -flagCanon :: String -> String -> Flag -flagCanon f v = Flg (identC (BS.pack f)) (identC (BS.pack v)) - --- for Ha-Jo 20/2/2005 - -prPrintnamesGrammar :: CanonGrammar -> String -prPrintnamesGrammar gr = unlines $ filter (not . null) [prPrint j | - (_,M.ModMod m) <- M.modules gr, - M.isModCnc m, - j <- tree2list $ M.jments m - ] - where - prPrint j = case j of - (c,CncCat _ _ p) -> "printname cat" +++ A.prt_ c +++ "=" +++ A.prt_ p - (c,CncFun _ _ _ p) -> "printname fun" +++ A.prt_ c +++ "=" +++ A.prt_ p - _ -> [] diff --git a/src-3.0/GF/Canon/GetGFC.hs b/src-3.0/GF/Canon/GetGFC.hs deleted file mode 100644 index 049f75efe..000000000 --- a/src-3.0/GF/Canon/GetGFC.hs +++ /dev/null @@ -1,78 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGFC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 18:39:43 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Canon.GetGFC (getCanonModule, getCanonGrammar) where - -import GF.Data.Operations -import GF.Canon.ParGFC -import GF.Canon.GFC -import GF.Canon.MkGFC -import GF.Infra.Modules -import GF.Infra.UseIO - -import System.IO -import System.Directory -import Control.Monad - -getCanonModule :: FilePath -> IOE CanonModule -getCanonModule file = do - gr <- getCanonGrammar file - case modules gr of - [m] -> return m - _ -> ioeErr $ Bad "expected exactly one module in a file" - -getCanonGrammar :: FilePath -> IOE CanonGrammar --- getCanonGrammar = getCanonGrammarByLine -getCanonGrammar file = do - s <- ioeIO $ readFileIf file - c <- ioeErr $ pCanon $ myLexer s - return $ canon2grammar c - -{- --- the following surprisingly does not save memory so it is --- not in use - -getCanonGrammarByLine :: FilePath -> IOE CanonGrammar -getCanonGrammarByLine file = do - b <- ioeIO $ doesFileExist file - if not b - then ioeErr $ Bad $ "file" +++ file +++ "does not exist" - else do - ioeIO $ putStrLn "" - hand <- ioeIO $ openFile file ReadMode ---- err - size <- ioeIO $ hFileSize hand - gr <- addNextLine (size,0) 1 hand emptyMGrammar - ioeIO $ hClose hand - return $ MGrammar $ reverse $ modules gr - - where - addNextLine (size,act) d hand gr = do - eof <- ioeIO $ hIsEOF hand - if eof - then return gr - else do - s <- ioeIO $ hGetLine hand - let act' = act + toInteger (length s) --- if isHash act act' then (ioeIO $ putChar '#') else return () - updGrammar act' d gr $ pLine $ myLexer s - where - updGrammar a d gr (Ok t) = case buildCanonGrammar d gr t of - (gr',d') -> addNextLine (size,a) d' hand gr' - updGrammar _ _ gr (Bad s) = do - ioeIO $ putStrLn s - return emptyMGrammar - - isHash a b = a `div` step < b `div` step - step = size `div` 50 --} diff --git a/src-3.0/GF/Canon/LexGFC.hs b/src-3.0/GF/Canon/LexGFC.hs deleted file mode 100644 index 31a4a9b30..000000000 --- a/src-3.0/GF/Canon/LexGFC.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "LexGFC.x" #-} -module GF.Canon.LexGFC where --H - -import GF.Data.ErrM --H -import GF.Data.SharedString --H - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#else -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x1d\x00\x00\x00\x0b\x00\x00\x00\x20\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\x6d\x01\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\x07\x00\x05\x00\x03\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\x03\x00\x04\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x08\x00\x0a\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0b\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x2b\x00\x3e\x00\x2a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]] -{-# LINE 32 "LexGFC.x" #-} - -tok f p s = f p s - -share :: String -> String -share = shareString - -data Tok = - TS !String -- reserved words - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N))) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c - -alex_action_1 = tok (\p s -> PT p (TS $ share s)) -alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_3 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) -alex_action_4 = tok (\p s -> PT p (TI $ share s)) -alex_action_5 = tok (\p s -> PT p (TD $ share s)) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - - -{-# LINE 35 "GenericTemplate.hs" #-} - - - - - - - - - - - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - case s of - -1# -> (last_acc, input) - _ -> alex_scan_tkn' user orig_input len input s last_acc - -alex_scan_tkn' user orig_input len input s last_acc = - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src-3.0/GF/Canon/LexGFC.x b/src-3.0/GF/Canon/LexGFC.x deleted file mode 100644 index 0a50e49d1..000000000 --- a/src-3.0/GF/Canon/LexGFC.x +++ /dev/null @@ -1,132 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -module GF.Canon.LexGFC where - -import GF.Data.ErrM -- H -import GF.Data.SharedString -- H -} - - -$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME -$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME -$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME -$d = [0-9] -- digit -$i = [$l $d _ '] -- identifier character -$u = [\0-\255] -- universal: any character - -@rsyms = -- reserved words consisting of special symbols - \; | \= | \{ | \} | \: | \- \> | \* \* | \[ | \] | \\ | \. | \( | \) | \_ | \< | \> | \$ | \? | \= \> | \! | \+ \+ | \/ | \@ | \+ | \| | \, - -:- - -$white+ ; -@rsyms { tok (\p s -> PT p (TS $ share s)) } - -$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } -\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) } - -$d+ { tok (\p s -> PT p (TI $ share s)) } - - -{ - -tok f p s = f p s - -share :: String -> String -share = shareString - -data Tok = - TS !String -- reserved words - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N))) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c -} diff --git a/src-3.0/GF/Canon/Look.hs b/src-3.0/GF/Canon/Look.hs deleted file mode 100644 index a93d4c834..000000000 --- a/src-3.0/GF/Canon/Look.hs +++ /dev/null @@ -1,225 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Look --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/20 09:32:56 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.17 $ --- --- lookup in GFC. AR 2003 ------------------------------------------------------------------------------ - -module GF.Canon.Look (lookupCncInfo, - lookupLin, - lookupLincat, - lookupPrintname, - lookupResInfo, - lookupGlobal, - lookupOptionsCan, - lookupParamValues, - allParamValues, - ccompute - ) where - -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Grammar.PrGrammar -import GF.Canon.CMacros -----import Values -import GF.Grammar.MMacros -import GF.Grammar.Macros (zIdent) -import qualified GF.Infra.Modules as M -import qualified GF.Canon.CanonToGrammar as CG - -import GF.Data.Operations -import GF.Infra.Option - -import Control.Monad -import Data.List - --- linearization lookup - -lookupCncInfo :: CanonGrammar -> CIdent -> Err Info -lookupCncInfo gr f@(CIQ m c) = do - mt <- M.lookupModule gr m - case mt of - M.ModMod a -> errIn ("module" +++ prt m) $ - lookupIdent c $ M.jments a - _ -> prtBad "not concrete module" m - -lookupLin :: CanonGrammar -> CIdent -> Err Term -lookupLin gr f = errIn "looking up linearization rule" $ do - info <- lookupCncInfo gr f - case info of - CncFun _ _ t _ -> return t - CncCat _ t _ -> return t - AnyInd _ n -> lookupLin gr $ redirectIdent n f - -lookupLincat :: CanonGrammar -> CIdent -> Err CType -lookupLincat gr (CIQ _ c) | elem c [zIdent "String", zIdent "Int", zIdent "Float"] = - return defLinType --- ad hoc; not needed? cf. Grammar.Lookup.lookupLincat -lookupLincat gr f = errIn "looking up linearization type" $ do - info <- lookupCncInfo gr f - case info of - CncCat t _ _ -> return t - AnyInd _ n -> lookupLincat gr $ redirectIdent n f - _ -> prtBad "no lincat found for" f - -lookupPrintname :: CanonGrammar -> CIdent -> Err Term -lookupPrintname gr f = errIn "looking up printname" $ do - info <- lookupCncInfo gr f - case info of - CncFun _ _ _ t -> return t - CncCat _ _ t -> return t - AnyInd _ n -> lookupPrintname gr $ redirectIdent n f - -lookupResInfo :: CanonGrammar -> CIdent -> Err Info -lookupResInfo gr f@(CIQ m c) = do - mt <- M.lookupModule gr m - case mt of - M.ModMod a -> lookupIdent c $ M.jments a - _ -> prtBad "not resource module" m - -lookupGlobal :: CanonGrammar -> CIdent -> Err Term -lookupGlobal gr f = do - info <- lookupResInfo gr f - case info of - ResOper _ t -> return t - AnyInd _ n -> lookupGlobal gr $ redirectIdent n f - _ -> prtBad "cannot find global" f - -lookupOptionsCan :: CanonGrammar -> Err Options -lookupOptionsCan gr = do - let fs = M.allFlags gr - os <- mapM CG.redFlag fs - return $ options os - -lookupParamValues :: CanonGrammar -> CIdent -> Err [Term] -lookupParamValues gr pt@(CIQ m _) = do - info <- lookupResInfo gr pt - case info of - ResPar ps -> liftM concat $ mapM mkPar ps - AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt - _ -> prtBad "cannot find parameter type" pt - where - mkPar (ParD f co) = do - vs <- liftM combinations $ mapM (allParamValues gr) co - return $ map (Par (CIQ m f)) vs - --- this is needed since param type can also be a record type - -allParamValues :: CanonGrammar -> CType -> Err [Term] -allParamValues cnc ptyp = case ptyp of - Cn pc -> lookupParamValues cnc pc - RecType r -> do - let (ls,tys) = unzip [(l,t) | Lbg l t <- r] - tss <- mapM allPV tys - return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss] - TInts n -> return [EInt i | i <- [0..n]] - _ -> prtBad "cannot possibly find parameter values for" ptyp - where - allPV = allParamValues cnc - --- runtime computation on GFC objects - -ccompute :: CanonGrammar -> [Term] -> Term -> Err Term -ccompute cnc = vcomp - where - - vcomp xs t = do - let xss = variations xs - ts <- mapM (\xx -> comp [] xx t) xss - return $ variants ts - - variations xs = combinations [getVariants t | t <- xs] - variants ts = case ts of - [t] -> t - _ -> FV ts - getVariants t = case t of - FV ts -> ts - _ -> [t] - - comp g xs t = case t of - Arg (A _ i) -> err (const (return t)) return $ xs !? fromInteger i - Arg (AB _ _ i) -> err (const (return t)) return $ xs !? fromInteger i - I c -> look c - LI c -> lookVar c g - - -- short-cut computation of selections: compute the table only if needed - S u v -> do - u' <- compt u - case u' of - T _ [Cas [PW] b] -> compt b - T _ [Cas [PV x] b] -> do - v' <- compt v - comp ((x,v') : g) xs b - T _ cs -> do - v' <- compt v - if noVar v' - then matchPatt cs v' >>= compt - else return $ S u' v' - FV ccs -> do - v' <- compt v - mapM (\c -> compt (S c v')) ccs >>= return . FV - - _ -> liftM (S u') $ compt v - - P u l -> do - u' <- compt u - case u' of - R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u')) - return $ - lookup l [ (x,y) | Ass x y <- rs] - FV rrs -> do - mapM (\r -> compt (P r l)) rrs >>= return . FV - - _ -> return $ P u' l - FV ts -> liftM FV (mapM compt ts) - C E b -> compt b - C a E -> compt a - C a b -> do - a' <- compt a - b' <- compt b - return $ case (a',b') of - (E,_) -> b' - (_,E) -> a' - _ -> C a' b' - R rs -> liftM (R . map (uncurry Ass)) $ - mapPairsM compt [(l,r) | Ass l r <- rs] - - -- only expand the table when the table is really needed: use expandLin - T ty rs -> liftM (T ty . map (uncurry Cas)) $ - mapPairsM compt [(l,r) | Cas l r <- rs] - - V ptyp ts -> do - ts' <- mapM compt ts - vs0 <- allParamValues cnc ptyp - vs <- mapM term2patt vs0 - let cc = [Cas [p] u | (p,u) <- zip vs ts'] - return $ T ptyp cc - - Par c xs -> liftM (Par c) $ mapM compt xs - - K (KS []) -> return E --- should not be needed - - _ -> return t - where - compt = comp g xs - look c = lookupGlobal cnc c >>= compt - - lookVar c co = case lookup c co of - Just t -> return t - _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- - - noVar v = case v of - LI _ -> False - Arg _ -> False - R rs -> all noVar [t | Ass _ t <- rs] - Par _ ts -> all noVar ts - FV ts -> all noVar ts - S x y -> noVar x && noVar y - P t _ -> noVar t - _ -> True --- other cases that can be values to pattern match? diff --git a/src-3.0/GF/Canon/MkGFC.hs b/src-3.0/GF/Canon/MkGFC.hs deleted file mode 100644 index 8443354fc..000000000 --- a/src-3.0/GF/Canon/MkGFC.hs +++ /dev/null @@ -1,237 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkGFC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/04 11:45:38 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr, - canon2grammar, grammar2canon, -- buildCanonGrammar, - info2mod,info2def, - trExp, rtExp, rtQIdent) where - -import GF.Canon.GFC -import GF.Canon.AbsGFC -import qualified GF.Grammar.Abstract as A -import GF.Grammar.PrGrammar - -import GF.Infra.Ident -import GF.Data.Operations -import qualified GF.Infra.Modules as M - -prCanonModInfo :: CanonModule -> String -prCanonModInfo = prt . info2mod - -prCanon :: CanonGrammar -> String -prCanon = unlines . map prCanonModInfo . M.modules - -prCanonMGr :: CanonGrammar -> String -prCanonMGr g = header ++++ prCanon g where - header = case M.greatestAbstract g of - Just a -> prt (MGr (M.allConcretes g a) a []) - _ -> [] - -canon2grammar :: Canon -> CanonGrammar -canon2grammar (MGr _ _ modules) = canon2grammar (Gr modules) ---- ignoring the header -canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules - -mod2info m = case m of - Mod mt e os flags defs -> - let defs' = buildTree $ map def2info defs - (a,mt') = case mt of - MTAbs a -> (a,M.MTAbstract) - MTRes a -> (a,M.MTResource) - MTCnc a x -> (a,M.MTConcrete x) - MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y)) - in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs')) - where - ee (Ext m) = map M.inheritAll m - ee _ = [] - oo (Opens ms) = map M.oSimple ms - oo _ = [] - -grammar2canon :: CanonGrammar -> Canon -grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules - -info2mod :: (Ident, M.ModInfo Ident Flag Info) -> Module -info2mod m = case m of - (a, M.ModMod (M.Module mt _ flags me os defs)) -> - let defs' = map info2def $ tree2list defs - mt' = case mt of - M.MTAbstract -> MTAbs a - M.MTResource -> MTRes a - M.MTConcrete x -> MTCnc a x - M.MTTransfer (M.OSimple _ x) (M.OSimple _ y) -> MTTrans a x y - in - Mod mt' (gfcE me) (gfcO os) flags defs' - where - gfcE = ifNull NoExt Ext . map fst - gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os] - - --- these translations are meant to be trivial - -defs2infos = sorted2tree . map def2info - -def2info d = case d of - AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs)) - AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df)) - AbsDTrans c t -> (c,AbsTrans (trExp t)) - ResDPar c df -> (c,ResPar df) - ResDOper c ty df -> (c,ResOper ty df) - CncDCat c ty df pr -> (c, CncCat ty df pr) - CncDFun f c xs li pr -> (f, CncFun c xs li pr) - AnyDInd c b m -> (c, AnyInd (b == Canon) m) - --- from file to internal - -trCont cont = [(x,trExp t) | Decl x t <- cont] - -trFs = map trQIdent - -trExp :: Exp -> A.Term -trExp t = case t of - EProd x a b -> A.Prod x (trExp a) (trExp b) - EAbs x b -> A.Abs x (trExp b) - EApp f a -> A.App (trExp f) (trExp a) - EEq eqs -> A.Eqs [(map trPt ps, trExp e) | Equ ps e <- eqs] - EData -> A.EData - _ -> trAt t - where - trAt (EAtom t) = case t of - AC c -> (uncurry A.Q) $ trQIdent c - AD c -> (uncurry A.QC) $ trQIdent c - AV v -> A.Vr v - AM i -> A.Meta $ A.MetaSymb $ fromInteger i - AT s -> A.Sort $ prt s - AS s -> A.K s - AI i -> A.EInt $ i - AF i -> A.EFloat $ i - trPt p = case p of - APC mc ps -> let (m,c) = trQIdent mc in A.PP m c (map trPt ps) - APV x -> A.PV x - APS s -> A.PString s - API i -> A.PInt $ i - APF i -> A.PFloat $ i - APW -> A.PW - -trQIdent (CIQ m c) = (m,c) - --- from internal to file - -infos2defs = map info2def . tree2list - -info2def d = case d of - (c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs) - (c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df) - (c,AbsTrans t) -> AbsDTrans c (rtExp t) - (c,ResPar df) -> ResDPar c df - (c,ResOper ty df) -> ResDOper c ty df - (c,CncCat ty df pr) -> CncDCat c ty df pr - (f,CncFun c xs li pr) -> CncDFun f c xs li pr - (c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m - -rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont] - -rtFs = map rtQIdent - -rtExp :: A.Term -> Exp -rtExp t = case t of - A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b) - A.Abs x b -> EAbs (rtIdent x) (rtExp b) - A.App f a -> EApp (rtExp f) (rtExp a) - A.Eqs eqs -> EEq [Equ (map rtPt ps) (rtExp e) | (ps,e) <- eqs] - A.EData -> EData - _ -> EAtom $ rtAt t - where - rtAt t = case t of - A.Q m c -> AC $ rtQIdent (m,c) - A.QC m c -> AD $ rtQIdent (m,c) - A.Vr v -> AV v - A.Meta i -> AM $ toInteger $ A.metaSymbInt i - A.Sort "Type" -> AT SType - A.K s -> AS s - A.EInt i -> AI $ toInteger i - _ -> error $ "MkGFC.rt not defined for" +++ show t - rtPt p = case p of - A.PP m c ps -> APC (rtQIdent (m,c)) (map rtPt ps) - A.PV x -> APV x - A.PString s -> APS s - A.PInt i -> API $ toInteger i - A.PW -> APW - _ -> error $ "MkGFC.rt not defined for" +++ show p - - -rtQIdent :: (Ident, Ident) -> CIdent -rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c) -rtIdent x - | isWildIdent x = identC "h_" --- needed in declarations - | otherwise = identC $ prt x --- - -{- --- the following is called in GetGFC to read gfc files line --- by line. It does not save memory, though, and is therefore --- not used. - -buildCanonGrammar :: Int -> CanonGrammar -> Line -> (CanonGrammar,Int) -buildCanonGrammar n gr0 line = mgr $ case line of --- LMulti ids id - LHeader mt ext op -> newModule mt ext op - LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n - LFlag flag -> newFlag flag - LDef def -> newDef $ def2info def --- LEnd -> cleanNames - _ -> M.modules gr0 - where - newModule mt ext op = mod2info (Mod mt ext op [] []) : mods - initModule f i = case actm of - (name, M.ModMod (M.Module mt com flags ee oo defs)) -> - (name, M.ModMod (M.Module mt com (f:flags) ee oo (newtree i))) : tmods - newFlag f = case actm of - (name, M.ModMod (M.Module mt com flags ee oo defs)) -> - (name, M.ModMod (M.Module mt com (f:flags) ee oo defs)) : tmods - newDef d = case actm of - (name, M.ModMod (M.Module mt com flags ee oo defs)) -> - (name, M.ModMod (M.Module mt com flags ee oo - (upd (padd 8 n) d defs))) : tmods - --- cleanNames = case actm of --- (name, M.ModMod (M.Module mt com flags ee oo defs)) -> --- (name, M.ModMod (M.Module mt com (reverse flags) ee oo --- (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods - - actm = head mods -- only used when a new mod has been created - mods = M.modules gr0 - tmods = tail mods - - mgr ms = (M.MGrammar ms, case line of - LDef _ -> n+1 - LEnd -> 1 - _ -> n - ) - - -- create an initial tree with who-cares value - newtree (i :: Int) = emptyBinTree --- newtree (i :: Int) = sorted2tree [ --- (padd 8 k, ResPar []) | --- k <- [1..i]] --- padd (length (show i)) - - padd l k = 0 --- padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk) - - upd _ d defs = updateTree d defs --- upd n d@(f,t) defs = case defs of --- NT -> BT (merg n f,t) NT NT --- should not happen --- BT c@(a,_) left right --- | n < a -> let left' = upd n d left in BT c left' right --- | n > a -> let right' = upd n d right in BT c left right' --- | otherwise -> BT (merg n f,t) left right --- merg (IC n) (IC f) = IC (n ++ f) --} diff --git a/src-3.0/GF/Canon/ParGFC.hs b/src-3.0/GF/Canon/ParGFC.hs deleted file mode 100644 index 4332c06e4..000000000 --- a/src-3.0/GF/Canon/ParGFC.hs +++ /dev/null @@ -1,2142 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -module GF.Canon.ParGFC where -- H -import GF.Canon.AbsGFC -- H -import GF.Canon.LexGFC -- H -import GF.Data.ErrM -- H -import GF.Infra.Ident -- H -import Array -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.15 - -newtype HappyAbsSyn = HappyAbsSyn (() -> ()) -happyIn5 :: (Ident) -> (HappyAbsSyn ) -happyIn5 x = unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Ident) -happyOut5 x = unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (String) -> (HappyAbsSyn ) -happyIn6 x = unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (String) -happyOut6 x = unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (Integer) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (Integer) -happyOut7 x = unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Double) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (Double) -happyOut8 x = unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Canon) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Canon) -happyOut9 x = unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (Line) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (Line) -happyOut10 x = unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Module) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Module) -happyOut11 x = unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (ModType) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (ModType) -happyOut12 x = unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: ([Module]) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> ([Module]) -happyOut13 x = unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (Extend) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (Extend) -happyOut14 x = unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (Open) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (Open) -happyOut15 x = unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (Flag) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (Flag) -happyOut16 x = unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: (Def) -> (HappyAbsSyn ) -happyIn17 x = unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> (Def) -happyOut17 x = unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (ParDef) -> (HappyAbsSyn ) -happyIn18 x = unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (ParDef) -happyOut18 x = unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: (Status) -> (HappyAbsSyn ) -happyIn19 x = unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (Status) -happyOut19 x = unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (CIdent) -> (HappyAbsSyn ) -happyIn20 x = unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (CIdent) -happyOut20 x = unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (Exp) -> (HappyAbsSyn ) -happyIn21 x = unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (Exp) -happyOut21 x = unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Exp) -> (HappyAbsSyn ) -happyIn22 x = unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Exp) -happyOut22 x = unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: (Exp) -> (HappyAbsSyn ) -happyIn23 x = unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> (Exp) -happyOut23 x = unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (Sort) -> (HappyAbsSyn ) -happyIn24 x = unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Sort) -happyOut24 x = unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (Equation) -> (HappyAbsSyn ) -happyIn25 x = unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (Equation) -happyOut25 x = unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (APatt) -> (HappyAbsSyn ) -happyIn26 x = unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (APatt) -happyOut26 x = unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: ([Decl]) -> (HappyAbsSyn ) -happyIn27 x = unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> ([Decl]) -happyOut27 x = unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: ([APatt]) -> (HappyAbsSyn ) -happyIn28 x = unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> ([APatt]) -happyOut28 x = unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: ([Equation]) -> (HappyAbsSyn ) -happyIn29 x = unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> ([Equation]) -happyOut29 x = unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (Atom) -> (HappyAbsSyn ) -happyIn30 x = unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (Atom) -happyOut30 x = unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: (Decl) -> (HappyAbsSyn ) -happyIn31 x = unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> (Decl) -happyOut31 x = unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (CType) -> (HappyAbsSyn ) -happyIn32 x = unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (CType) -happyOut32 x = unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (Labelling) -> (HappyAbsSyn ) -happyIn33 x = unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (Labelling) -happyOut33 x = unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: (Term) -> (HappyAbsSyn ) -happyIn34 x = unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> (Term) -happyOut34 x = unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: (Term) -> (HappyAbsSyn ) -happyIn35 x = unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> (Term) -happyOut35 x = unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: (Term) -> (HappyAbsSyn ) -happyIn36 x = unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> (Term) -happyOut36 x = unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: (Tokn) -> (HappyAbsSyn ) -happyIn37 x = unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (Tokn) -happyOut37 x = unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: (Assign) -> (HappyAbsSyn ) -happyIn38 x = unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> (Assign) -happyOut38 x = unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: (Case) -> (HappyAbsSyn ) -happyIn39 x = unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> (Case) -happyOut39 x = unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: (Variant) -> (HappyAbsSyn ) -happyIn40 x = unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> (Variant) -happyOut40 x = unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: (Label) -> (HappyAbsSyn ) -happyIn41 x = unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (Label) -happyOut41 x = unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: (ArgVar) -> (HappyAbsSyn ) -happyIn42 x = unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> (ArgVar) -happyOut42 x = unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: (Patt) -> (HappyAbsSyn ) -happyIn43 x = unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> (Patt) -happyOut43 x = unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: (PattAssign) -> (HappyAbsSyn ) -happyIn44 x = unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> (PattAssign) -happyOut44 x = unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: ([Flag]) -> (HappyAbsSyn ) -happyIn45 x = unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> ([Flag]) -happyOut45 x = unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: ([Def]) -> (HappyAbsSyn ) -happyIn46 x = unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> ([Def]) -happyOut46 x = unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: ([ParDef]) -> (HappyAbsSyn ) -happyIn47 x = unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> ([ParDef]) -happyOut47 x = unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: ([CType]) -> (HappyAbsSyn ) -happyIn48 x = unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> ([CType]) -happyOut48 x = unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: ([CIdent]) -> (HappyAbsSyn ) -happyIn49 x = unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> ([CIdent]) -happyOut49 x = unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: ([Assign]) -> (HappyAbsSyn ) -happyIn50 x = unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> ([Assign]) -happyOut50 x = unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: ([ArgVar]) -> (HappyAbsSyn ) -happyIn51 x = unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> ([ArgVar]) -happyOut51 x = unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: ([Labelling]) -> (HappyAbsSyn ) -happyIn52 x = unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> ([Labelling]) -happyOut52 x = unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: ([Case]) -> (HappyAbsSyn ) -happyIn53 x = unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> ([Case]) -happyOut53 x = unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: ([Term]) -> (HappyAbsSyn ) -happyIn54 x = unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> ([Term]) -happyOut54 x = unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: ([String]) -> (HappyAbsSyn ) -happyIn55 x = unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> ([String]) -happyOut55 x = unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: ([Variant]) -> (HappyAbsSyn ) -happyIn56 x = unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> ([Variant]) -happyOut56 x = unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: ([PattAssign]) -> (HappyAbsSyn ) -happyIn57 x = unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> ([PattAssign]) -happyOut57 x = unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: ([Patt]) -> (HappyAbsSyn ) -happyIn58 x = unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> ([Patt]) -happyOut58 x = unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: ([Ident]) -> (HappyAbsSyn ) -happyIn59 x = unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> ([Ident]) -happyOut59 x = unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x74\x02\xa7\x00\x6e\x02\x00\x00\x6c\x02\x66\x02\x89\x02\x88\x02\x84\x02\x00\x00\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x52\x02\x21\x02\x60\x02\x6d\x02\x5e\x02\x00\x00\x82\x02\x5b\x02\xdb\x00\x00\x00\x80\x02\x7e\x02\x7d\x02\x79\x02\x59\x02\x78\x02\x7a\x02\x58\x02\x73\x02\x00\x00\x00\x00\x00\x00\x28\x00\x53\x02\x00\x00\x46\x02\x51\x02\x72\x02\x44\x02\x44\x02\x44\x02\x8b\x00\x44\x02\x44\x02\x9b\x00\x9b\x00\x44\x02\x8b\x00\x44\x02\x71\x02\x28\x00\x42\x02\x42\x02\x00\x00\x70\x02\x4b\x02\x6a\x02\x64\x02\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x02\x8b\x00\x38\x02\x38\x02\x3f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x00\x00\x6b\x02\xf7\xff\x9b\x00\x39\x02\x00\x00\x69\x02\x68\x02\x67\x02\x65\x02\x00\x00\x00\x00\x61\x02\x5c\x02\x63\x02\x00\x00\x5f\x02\x30\x02\x00\x00\x3e\x02\x00\x00\x2f\x02\x5d\x02\x8b\x00\x8b\x00\x00\x00\x54\x02\x12\x00\x00\x00\x4a\x02\x00\x00\x5a\x02\x57\x02\x56\x02\x26\x02\x12\x00\x27\x02\x9b\x00\x00\x00\x00\x00\x47\x02\xd7\x00\x48\x02\x50\x02\x4d\x02\x00\x00\x8b\x00\x23\x02\x23\x02\x4f\x02\x00\x00\x21\x02\x00\x00\x00\x00\x00\x00\x4e\x02\x7e\x00\x00\x00\x8b\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x02\x36\x02\x33\x02\x00\x00\x00\x00\xf7\xff\xfe\xff\x12\x00\x16\x02\x16\x02\x9b\x00\x43\x02\x00\x00\x00\x00\x00\x00\x9b\x00\xf7\xff\x9b\x00\xba\x00\x14\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x02\x66\x00\x2a\x02\x3d\x02\x12\x00\x12\x00\x35\x02\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x07\x00\x00\x00\x00\x00\x3c\x02\x2c\x02\x29\x02\x5f\x00\xf7\xff\x0d\x02\x0d\x02\x1e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\xfb\x01\x00\x00\x00\x00\x08\x02\x28\x02\xb4\x00\x00\x00\x00\x00\x22\x02\x0c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\xf7\xff\x1a\x00\x00\x00\x55\x00\x10\x02\x00\x00\x4f\x00\x00\x00\xff\x01\xfc\x01\x12\x00\xe1\x01\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x1d\x00\x0f\x02\x0a\x02\x65\x00\x00\x00\x00\x00\x6f\x00\x00\x00\xfa\x01\xd6\x01\x8b\x00\xda\x00\xf9\x01\x00\x00\xc8\x01\x00\x00\xf6\x01\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x01\x59\x00\xf3\x01\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\xc5\x01\x00\x00\x12\x00\x00\x00\xf0\x01\x00\x00\x12\x00\xc9\x01\x00\x00\xc9\x01\x00\x00\xdd\x01\xdc\x01\xd8\x01\xd1\x01\x00\x00\x37\x00\x00\x00\xa9\x01\x00\x00\x00\x00\xf7\xff\x16\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x9c\x00\x5d\x01\x00\x00\x00\x00\xb7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\xc2\x01\xc1\x01\xbc\x01\xb1\x01\x06\x00\xb0\x01\xa8\x01\xa4\x01\x8f\x01\x8e\x01\x8c\x01\x00\x00\x6e\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x86\x01\x72\x01\x00\x00\x9f\x00\x7b\x01\x70\x01\x25\x02\x65\x01\xe0\x01\x36\x01\x19\x01\xa6\x00\x20\x02\x52\x01\x00\x00\x01\x00\x40\x01\x04\x00\x00\x00\x00\x00\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x3c\x01\x0b\x02\xc6\x01\x3b\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x18\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x06\x02\xf1\x01\x00\x00\x00\x00\x7e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x01\x6b\x01\x6a\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xec\x01\x1f\x01\x1d\x01\x00\x00\x14\x01\x6e\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xab\x01\x00\x00\xd7\x01\x00\x00\xd2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x58\x01\xb4\x01\xfd\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x0f\x00\x0c\x00\x00\x00\x35\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\xa6\x01\x00\x00\x00\x00\x00\x00\x54\x01\x82\x01\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x96\x01\x0e\x00\xe8\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x01\x37\x01\x00\x00\x00\x00\x51\x00\x00\x00\x03\x01\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\xc0\x00\xa1\x00\x00\x00\x92\x01\x3a\x01\x5c\x00\x92\x01\x00\x00\x00\x00\x00\x00\x2e\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x01\x00\x00\x00\x00\xff\x00\x00\x00\x00\x00\x77\x01\x00\x00\x00\x00\x74\x00\xb8\x01\xab\x01\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x10\x00\x00\x00\x2a\x01\x00\x00\x3d\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\x91\x00\x00\x00\x17\x00\x00\x00\x00\x00\x09\x00\xf8\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xed\xff\x00\x00\x00\x00\xfd\xff\xdc\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x6f\xff\x6e\xff\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xff\xf4\xff\xf5\xff\xea\xff\x00\x00\xdd\xff\x00\x00\xe8\xff\x00\x00\xc9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xff\x00\x00\x00\x00\x00\x00\xea\xff\x00\x00\x6f\xff\x6d\xff\x00\x00\xe8\xff\x00\x00\x00\x00\xbe\xff\xbd\xff\xc2\xff\xd5\xff\xe4\xff\xd9\xff\xbc\xff\xd4\xff\xc4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\xff\xd3\xff\xfc\xff\xfb\xff\x8b\xff\x8d\xff\xe3\xff\xb8\xff\x00\x00\x81\xff\x00\x00\x00\x00\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\xf0\xff\x00\x00\x00\x00\xc8\xff\xeb\xff\x00\x00\x6f\xff\xdf\xff\x00\x00\xf6\xff\xc9\xff\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\x00\x00\xb6\xff\x00\x00\x9d\xff\x80\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xff\xde\xff\xbf\xff\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xff\xda\xff\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xf9\xff\x92\xff\xee\xff\xdb\xff\x00\x00\x00\x00\xd6\xff\x00\x00\xd2\xff\x00\x00\xc1\xff\x8a\xff\x8c\xff\x00\x00\xa2\xff\xaf\xff\xae\xff\xb3\xff\xa5\xff\xa3\xff\xe2\xff\xad\xff\xb4\xff\x87\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x9c\xff\xba\xff\x00\x00\x81\xff\x00\x00\x00\x00\x84\xff\xe5\xff\xbb\xff\x89\xff\xc7\xff\xe9\xff\xe6\xff\x00\x00\x83\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xff\xb5\xff\x7b\xff\x00\x00\xb1\xff\x7b\xff\x00\x00\xac\xff\x79\xff\x86\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xff\xce\xff\xcd\xff\xcc\xff\xcb\xff\xc5\xff\x00\x00\x00\x00\xca\xff\xc3\xff\x90\xff\x00\x00\x00\x00\xc6\xff\xd0\xff\x00\x00\x00\x00\x9b\xff\xaa\xff\xa7\xff\xb0\xff\x00\x00\x87\xff\x00\x00\xab\xff\x00\x00\x71\xff\x7b\xff\x00\x00\xb9\xff\xa4\xff\xe1\xff\x00\x00\x84\xff\x88\xff\x82\xff\x00\x00\x7a\xff\xa6\xff\x00\x00\x7d\xff\x00\x00\x00\x00\xb2\xff\x78\xff\x77\xff\x85\xff\xa0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\x00\x00\x91\xff\x00\x00\x8f\xff\xcf\xff\xd8\xff\x9a\xff\x76\xff\x00\x00\x00\x00\x98\xff\x95\xff\x94\xff\x70\xff\x74\xff\x00\x00\x97\xff\x00\x00\xa9\xff\x71\xff\xa8\xff\x00\x00\xe0\xff\x7c\xff\x9f\xff\x71\xff\x00\x00\x73\xff\x00\x00\x00\x00\x79\xff\x77\xff\x75\xff\x9e\xff\xa1\xff\x96\xff\x74\xff\x00\x00\x00\x00\x99\xff\x93\xff\x72\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x11\x00\x00\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x14\x00\x0d\x00\x03\x00\x17\x00\x35\x00\x01\x00\x03\x00\x08\x00\x0f\x00\x15\x00\x03\x00\x0c\x00\x0f\x00\x03\x00\x0f\x00\x0c\x00\x11\x00\x0e\x00\x08\x00\x09\x00\x1b\x00\x31\x00\x0c\x00\x2c\x00\x1c\x00\x0f\x00\x24\x00\x11\x00\x07\x00\x27\x00\x24\x00\x24\x00\x24\x00\x27\x00\x00\x00\x25\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x34\x00\x2f\x00\x2e\x00\x2e\x00\x34\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x31\x00\x01\x00\x33\x00\x34\x00\x03\x00\x32\x00\x16\x00\x31\x00\x32\x00\x33\x00\x34\x00\x03\x00\x04\x00\x0c\x00\x0d\x00\x0e\x00\x08\x00\x03\x00\x31\x00\x25\x00\x0c\x00\x0b\x00\x08\x00\x0f\x00\x22\x00\x11\x00\x0c\x00\x03\x00\x2e\x00\x0f\x00\x10\x00\x11\x00\x08\x00\x03\x00\x32\x00\x00\x00\x0c\x00\x00\x00\x30\x00\x0f\x00\x16\x00\x11\x00\x0c\x00\x35\x00\x0e\x00\x06\x00\x07\x00\x02\x00\x0d\x00\x13\x00\x31\x00\x29\x00\x33\x00\x34\x00\x17\x00\x18\x00\x00\x00\x31\x00\x32\x00\x33\x00\x34\x00\x06\x00\x16\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x00\x32\x00\x0e\x00\x31\x00\x03\x00\x00\x00\x31\x00\x32\x00\x33\x00\x34\x00\x2a\x00\x0a\x00\x31\x00\x0c\x00\x33\x00\x34\x00\x0f\x00\x1c\x00\x11\x00\x12\x00\x03\x00\x00\x00\x04\x00\x32\x00\x01\x00\x24\x00\x08\x00\x16\x00\x00\x00\x0c\x00\x1d\x00\x1a\x00\x17\x00\x04\x00\x21\x00\x01\x00\x2f\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0d\x00\x23\x00\x16\x00\x1b\x00\x1c\x00\x04\x00\x1a\x00\x03\x00\x01\x00\x31\x00\x32\x00\x33\x00\x08\x00\x00\x00\x15\x00\x32\x00\x32\x00\x33\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x23\x00\x24\x00\x31\x00\x26\x00\x27\x00\x15\x00\x2a\x00\x2a\x00\x2b\x00\x1f\x00\x2d\x00\x02\x00\x2f\x00\x23\x00\x31\x00\x31\x00\x26\x00\x27\x00\x05\x00\x02\x00\x2a\x00\x2b\x00\x05\x00\x21\x00\x0b\x00\x2f\x00\x24\x00\x31\x00\x0c\x00\x0d\x00\x0e\x00\x21\x00\x02\x00\x0c\x00\x24\x00\x2d\x00\x0f\x00\x00\x00\x11\x00\x12\x00\x31\x00\x2c\x00\x00\x00\x2d\x00\x02\x00\x03\x00\x00\x00\x00\x00\x02\x00\x03\x00\x1d\x00\x00\x00\x0f\x00\x00\x00\x21\x00\x02\x00\x03\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x0b\x00\x1b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x00\x31\x00\x32\x00\x33\x00\x0f\x00\x1b\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x26\x00\x28\x00\x08\x00\x00\x00\x26\x00\x00\x00\x02\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x26\x00\x0f\x00\x0f\x00\x0f\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1b\x00\x1b\x00\x1b\x00\x02\x00\x00\x00\x00\x00\x2b\x00\x0f\x00\x02\x00\x00\x00\x00\x00\x0f\x00\x18\x00\x0a\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x0f\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x25\x00\x0f\x00\x1b\x00\x00\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x22\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x05\x00\x0f\x00\x07\x00\x00\x00\x25\x00\x0f\x00\x0b\x00\x0c\x00\x30\x00\x00\x00\x01\x00\x02\x00\x03\x00\x35\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x25\x00\x0f\x00\x00\x00\x0a\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x25\x00\x0f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x1d\x00\x1e\x00\x0f\x00\x20\x00\x25\x00\x00\x00\x0f\x00\x00\x00\x25\x00\x00\x00\x32\x00\x33\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1d\x00\x00\x00\x00\x00\x20\x00\x1d\x00\x00\x00\x0f\x00\x20\x00\x25\x00\x00\x00\x01\x00\x02\x00\x25\x00\x00\x00\x00\x00\x01\x00\x02\x00\x15\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x0f\x00\x19\x00\x00\x00\x01\x00\x02\x00\x09\x00\x32\x00\x04\x00\x01\x00\x15\x00\x02\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x0f\x00\x19\x00\x00\x00\x01\x00\x02\x00\x04\x00\x01\x00\x31\x00\x04\x00\x02\x00\x31\x00\x01\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x33\x00\x19\x00\x00\x00\x01\x00\x02\x00\x04\x00\x15\x00\x01\x00\x15\x00\x31\x00\x14\x00\x04\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x17\x00\x19\x00\x00\x00\x01\x00\x02\x00\x06\x00\x01\x00\x22\x00\x0d\x00\x31\x00\x04\x00\x02\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x01\x00\x19\x00\x1e\x00\x33\x00\x20\x00\x0d\x00\x06\x00\x1a\x00\x31\x00\x03\x00\x31\x00\x15\x00\x0f\x00\x14\x00\x0b\x00\x12\x00\x13\x00\x2d\x00\x01\x00\x2f\x00\x04\x00\x03\x00\x19\x00\x31\x00\x0d\x00\x06\x00\x10\x00\x31\x00\x33\x00\x04\x00\x01\x00\x05\x00\x13\x00\x0a\x00\x02\x00\x31\x00\x31\x00\x03\x00\x25\x00\x01\x00\x09\x00\x05\x00\x02\x00\x01\x00\x31\x00\x02\x00\x02\x00\x33\x00\x02\x00\x19\x00\x0b\x00\x06\x00\x01\x00\x33\x00\x31\x00\x29\x00\x31\x00\x05\x00\x31\x00\x25\x00\x07\x00\x29\x00\x08\x00\x02\x00\x05\x00\x05\x00\x02\x00\x28\x00\x28\x00\x02\x00\x05\x00\x02\x00\x01\x00\x28\x00\x1a\x00\x36\x00\x01\x00\xff\xff\x02\x00\x31\x00\x21\x00\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\xc8\x00\x7e\x00\x79\x00\x43\x00\x30\x00\x45\x00\x79\x00\x79\x00\x79\x00\x45\x00\xba\x00\x27\x01\x92\x00\xea\x00\xa6\x00\x93\x00\x2c\x01\xfd\x00\x15\x01\xa7\x00\x5b\x00\xbf\x00\xff\x00\xa8\x00\x1f\x01\xa6\x00\xa9\x00\x16\x01\xaa\x00\x17\x01\xa7\x00\x1b\x01\xbf\x00\x04\x00\xa8\x00\xc9\x00\x7a\x00\xa9\x00\x20\x01\xaa\x00\x6f\xff\x21\x01\x20\x01\xe3\x00\x7b\x00\x21\x01\xba\x00\xbb\x00\x31\x00\x31\x00\x6e\x00\x41\x00\x1a\x00\x24\x00\x2f\x01\xc0\x00\xf4\x00\xab\x00\x22\x01\xac\x00\x04\x00\x57\x00\x58\x00\xad\x00\x04\x00\xfd\x00\x58\x00\xad\x00\x15\x01\x57\x00\x79\xff\x04\x00\x57\x00\x58\x00\xad\x00\xa6\x00\xf8\x00\x16\x01\x2e\x01\x17\x01\xa7\x00\xa6\x00\x04\x00\xbb\x00\xa8\x00\xdc\x00\xa7\x00\xa9\x00\xf9\x00\xaa\x00\xa8\x00\xa6\x00\xbc\x00\xa9\x00\xfd\x00\xaa\x00\xa7\x00\x15\x01\x79\xff\x58\x00\xa8\x00\x08\x01\x1d\x01\xa9\x00\x25\x01\xaa\x00\x16\x01\xfb\x00\x17\x01\x1b\x00\x1c\x00\x0c\x01\x59\x00\x18\x01\x04\x00\xdd\x00\x58\x00\xad\x00\xcf\x00\xd0\x00\x79\x00\x04\x00\x57\x00\x58\x00\xad\x00\xd8\x00\x79\xff\x04\x00\x57\x00\x58\x00\xad\x00\xd9\x00\x57\x00\xda\x00\xf8\x00\x4f\x00\x67\x00\x04\x00\x57\x00\x58\x00\xad\x00\x9a\x00\x50\x00\x04\x00\x51\x00\x58\x00\xad\x00\x52\x00\x7a\x00\x53\x00\x54\x00\x5e\x00\x67\x00\x16\x00\x79\xff\xfd\x00\x7b\x00\x17\x00\xb7\x00\x58\x00\x5f\x00\x55\x00\x69\x00\x03\x01\x0a\x00\x56\x00\x1c\x01\x7c\x00\x04\x00\x57\x00\x58\x00\xad\x00\x59\x00\x0d\x01\x68\x00\x60\x00\x61\x00\x06\x01\x69\x00\xec\x00\xbe\x00\x04\x00\x57\x00\x58\x00\xed\x00\x79\x00\xbf\x00\xe8\x00\x0e\x01\x26\x01\x0b\x00\x0c\x00\x0d\x00\x79\x00\x0e\x00\x0f\x00\x10\x00\x04\x00\x11\x00\x12\x00\xbf\x00\x5a\x00\x13\x00\x14\x00\x0c\x00\x15\x00\xe1\x00\x16\x00\x0f\x00\x04\x00\xea\x00\x11\x00\x12\x00\x98\x00\x3c\x00\x13\x00\x14\x00\x3d\x00\xc9\x00\x8b\x00\x07\x01\xca\x00\x04\x00\xd9\x00\x0b\x01\xda\x00\xc9\x00\xe2\x00\x8a\x00\xca\x00\xff\x00\x52\x00\x45\x00\x53\x00\x54\x00\xed\x00\xb9\x00\x10\x01\xcb\x00\x11\x01\x12\x01\x10\x01\x45\x00\x11\x01\x12\x01\x55\x00\xc4\x00\x5b\x00\x10\x01\x56\x00\x11\x01\x12\x01\x04\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x5b\x00\x8b\x00\xc1\x00\x04\x00\x57\x00\x58\x00\xad\x00\x04\x01\x04\x00\x57\x00\x58\x00\x9f\x00\xc3\x00\xcf\x00\xd0\x00\x45\x00\x45\x00\x45\x00\x13\x01\xdb\x00\x8e\x00\x90\x00\x2e\x01\x91\x00\xad\x00\xa0\x00\xa1\x00\x1c\x01\xa3\x00\x13\x01\x5b\x00\x5b\x00\x5b\x00\xa4\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x99\x00\x78\x00\x5c\x00\x77\x00\x45\x00\x45\x00\x80\x00\x9f\x00\x81\x00\x82\x00\x86\x00\x9f\x00\x87\x00\x8c\x00\x42\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x5b\x00\xde\x00\xa0\x00\xa1\x00\x1e\x01\xa3\x00\xa0\x00\xa1\x00\xf5\x00\xa3\x00\xa4\x00\x9f\x00\x61\x00\x44\x00\xa4\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\xf9\x00\x04\x00\xa0\x00\xa1\x00\x00\x01\xa3\x00\x05\x00\x9f\x00\x06\x00\x63\x00\xa4\x00\x9f\x00\x07\x00\x08\x00\xfa\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\xfb\x00\x65\x00\xa0\x00\xa1\x00\xf0\x00\xa3\x00\xa0\x00\xa1\x00\xc6\x00\xa3\x00\xa4\x00\x9f\x00\x66\x00\x6b\x00\xa4\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x6d\x00\x3d\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x1e\x00\x9f\x00\x1f\x00\x20\x00\xa4\x00\x9f\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x0d\x01\xa0\x00\xa1\x00\xb2\x00\xa3\x00\xa0\x00\xef\x00\x9f\x00\xa3\x00\xa4\x00\x21\x00\x9f\x00\x45\x00\xa4\x00\x22\x00\x0e\x01\x0f\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xf6\x00\x23\x00\x25\x00\xa3\x00\xe4\x00\x45\x00\xf3\x00\xa3\x00\xa4\x00\x45\x00\x46\x00\x47\x00\xa4\x00\x26\x00\x45\x00\x46\x00\x47\x00\xd6\x00\x27\x00\x28\x00\xc5\x00\x29\x00\x2d\x00\x45\x00\x48\x00\x49\x00\x0b\x01\x4b\x00\x4c\x00\x48\x00\x49\x00\xdf\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x83\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x29\x01\x57\x00\x2a\x01\x2b\x01\xbf\x00\x2c\x01\x45\x00\x48\x00\x49\x00\xd0\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\xd1\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x62\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x7e\xff\x26\x01\x04\x00\x24\x01\x3c\x00\x04\x00\x0a\x01\x48\x00\x49\x00\x85\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\xb4\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x58\x00\x4d\x00\x84\x00\x46\x00\x47\x00\x19\x01\xbf\x00\x1a\x01\xbf\x00\x04\x00\xcd\x00\x7e\xff\x48\x00\x49\x00\xb5\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\x85\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x02\x01\x4d\x00\x45\x00\x46\x00\x47\x00\x03\x01\x08\x01\x0e\x00\xe1\x00\x04\x00\xe6\x00\xe7\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\x64\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\xe8\x00\x4d\x00\x0b\x00\x58\x00\x0d\x00\xef\x00\xf2\x00\xf3\x00\x04\x00\xc3\x00\x04\x00\xbf\x00\x48\x00\xcd\x00\xce\x00\x88\x00\x4c\x00\x15\x00\xdb\x00\x1e\x00\x95\x00\x90\x00\x4d\x00\x04\x00\x97\x00\x96\x00\x99\x00\x04\x00\x58\x00\xaf\x00\xb1\x00\xb0\x00\xb2\x00\xb4\x00\xb7\x00\x04\x00\x04\x00\x70\x00\xb9\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x04\x00\x76\x00\x77\x00\x58\x00\x7f\x00\x80\x00\x8b\x00\x8c\x00\x8e\x00\x58\x00\x04\x00\x6d\x00\x04\x00\x3d\x00\x04\x00\x30\x00\x6b\x00\x6d\x00\x33\x00\x35\x00\x36\x00\x38\x00\x39\x00\x34\x00\x37\x00\x3b\x00\x3a\x00\x3f\x00\x2b\x00\x40\x00\x41\x00\xff\xff\x2c\x00\x00\x00\x2d\x00\x04\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (2, 146) [ - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146) - ] - -happy_n_terms = 55 :: Int -happy_n_nonterms = 55 :: Int - -happyReduce_2 = happySpecReduce_1 0# happyReduction_2 -happyReduction_2 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> - happyIn5 - (identC happy_var_1 --H - )} - -happyReduce_3 = happySpecReduce_1 1# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn6 - (happy_var_1 - )} - -happyReduce_4 = happySpecReduce_1 2# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn7 - ((read happy_var_1) :: Integer - )} - -happyReduce_5 = happySpecReduce_1 3# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> - happyIn8 - ((read happy_var_1) :: Double - )} - -happyReduce_6 = happyReduce 6# 4# happyReduction_6 -happyReduction_6 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_4 of { happy_var_4 -> - case happyOut13 happy_x_6 of { happy_var_6 -> - happyIn9 - (MGr happy_var_2 happy_var_4 (reverse happy_var_6) - ) `HappyStk` happyRest}}} - -happyReduce_7 = happySpecReduce_1 4# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - happyIn9 - (Gr (reverse happy_var_1) - )} - -happyReduce_8 = happyReduce 5# 5# happyReduction_8 -happyReduction_8 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_4 of { happy_var_4 -> - happyIn10 - (LMulti happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_9 = happyReduce 5# 5# happyReduction_9 -happyReduction_9 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_4 of { happy_var_4 -> - happyIn10 - (LHeader happy_var_1 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_10 = happySpecReduce_2 5# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - happyIn10 - (LFlag happy_var_1 - )} - -happyReduce_11 = happySpecReduce_2 5# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - happyIn10 - (LDef happy_var_1 - )} - -happyReduce_12 = happySpecReduce_1 5# happyReduction_12 -happyReduction_12 happy_x_1 - = happyIn10 - (LEnd - ) - -happyReduce_13 = happyReduce 8# 6# happyReduction_13 -happyReduction_13 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_4 of { happy_var_4 -> - case happyOut45 happy_x_6 of { happy_var_6 -> - case happyOut46 happy_x_7 of { happy_var_7 -> - happyIn11 - (Mod happy_var_1 happy_var_3 happy_var_4 (reverse happy_var_6) (reverse happy_var_7) - ) `HappyStk` happyRest}}}}} - -happyReduce_14 = happySpecReduce_2 7# happyReduction_14 -happyReduction_14 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_2 of { happy_var_2 -> - happyIn12 - (MTAbs happy_var_2 - )} - -happyReduce_15 = happyReduce 4# 7# happyReduction_15 -happyReduction_15 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_4 of { happy_var_4 -> - happyIn12 - (MTCnc happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_16 = happySpecReduce_2 7# happyReduction_16 -happyReduction_16 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_2 of { happy_var_2 -> - happyIn12 - (MTRes happy_var_2 - )} - -happyReduce_17 = happyReduce 6# 7# happyReduction_17 -happyReduction_17 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_4 of { happy_var_4 -> - case happyOut5 happy_x_6 of { happy_var_6 -> - happyIn12 - (MTTrans happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_18 = happySpecReduce_0 8# happyReduction_18 -happyReduction_18 = happyIn13 - ([] - ) - -happyReduce_19 = happySpecReduce_2 8# happyReduction_19 -happyReduction_19 happy_x_2 - happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn13 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_20 = happySpecReduce_2 9# happyReduction_20 -happyReduction_20 happy_x_2 - happy_x_1 - = case happyOut59 happy_x_1 of { happy_var_1 -> - happyIn14 - (Ext happy_var_1 - )} - -happyReduce_21 = happySpecReduce_0 9# happyReduction_21 -happyReduction_21 = happyIn14 - (NoExt - ) - -happyReduce_22 = happySpecReduce_3 10# happyReduction_22 -happyReduction_22 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut59 happy_x_2 of { happy_var_2 -> - happyIn15 - (Opens happy_var_2 - )} - -happyReduce_23 = happySpecReduce_0 10# happyReduction_23 -happyReduction_23 = happyIn15 - (NoOpens - ) - -happyReduce_24 = happyReduce 4# 11# happyReduction_24 -happyReduction_24 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_4 of { happy_var_4 -> - happyIn16 - (Flg happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_25 = happyReduce 7# 12# happyReduction_25 -happyReduction_25 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut27 happy_x_4 of { happy_var_4 -> - case happyOut49 happy_x_7 of { happy_var_7 -> - happyIn17 - (AbsDCat happy_var_2 happy_var_4 (reverse happy_var_7) - ) `HappyStk` happyRest}}} - -happyReduce_26 = happyReduce 6# 12# happyReduction_26 -happyReduction_26 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_4 of { happy_var_4 -> - case happyOut22 happy_x_6 of { happy_var_6 -> - happyIn17 - (AbsDFun happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_27 = happyReduce 4# 12# happyReduction_27 -happyReduction_27 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_4 of { happy_var_4 -> - happyIn17 - (AbsDTrans happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_28 = happyReduce 4# 12# happyReduction_28 -happyReduction_28 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut47 happy_x_4 of { happy_var_4 -> - happyIn17 - (ResDPar happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_29 = happyReduce 6# 12# happyReduction_29 -happyReduction_29 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut32 happy_x_4 of { happy_var_4 -> - case happyOut36 happy_x_6 of { happy_var_6 -> - happyIn17 - (ResDOper happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_30 = happyReduce 8# 12# happyReduction_30 -happyReduction_30 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut32 happy_x_4 of { happy_var_4 -> - case happyOut36 happy_x_6 of { happy_var_6 -> - case happyOut36 happy_x_8 of { happy_var_8 -> - happyIn17 - (CncDCat happy_var_2 happy_var_4 happy_var_6 happy_var_8 - ) `HappyStk` happyRest}}}} - -happyReduce_31 = happyReduce 11# 12# happyReduction_31 -happyReduction_31 (happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut20 happy_x_4 of { happy_var_4 -> - case happyOut51 happy_x_7 of { happy_var_7 -> - case happyOut36 happy_x_9 of { happy_var_9 -> - case happyOut36 happy_x_11 of { happy_var_11 -> - happyIn17 - (CncDFun happy_var_2 happy_var_4 happy_var_7 happy_var_9 happy_var_11 - ) `HappyStk` happyRest}}}}} - -happyReduce_32 = happyReduce 4# 12# happyReduction_32 -happyReduction_32 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_4 of { happy_var_4 -> - happyIn17 - (AnyDInd happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_33 = happySpecReduce_2 13# happyReduction_33 -happyReduction_33 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_2 of { happy_var_2 -> - happyIn18 - (ParD happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_34 = happySpecReduce_1 14# happyReduction_34 -happyReduction_34 happy_x_1 - = happyIn19 - (Canon - ) - -happyReduce_35 = happySpecReduce_0 14# happyReduction_35 -happyReduction_35 = happyIn19 - (NonCan - ) - -happyReduce_36 = happySpecReduce_3 15# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn20 - (CIQ happy_var_1 happy_var_3 - )}} - -happyReduce_37 = happySpecReduce_2 16# happyReduction_37 -happyReduction_37 happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn21 - (EApp happy_var_1 happy_var_2 - )}} - -happyReduce_38 = happySpecReduce_1 16# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn21 - (happy_var_1 - )} - -happyReduce_39 = happyReduce 7# 17# happyReduction_39 -happyReduction_39 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_4 of { happy_var_4 -> - case happyOut22 happy_x_7 of { happy_var_7 -> - happyIn22 - (EProd happy_var_2 happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}} - -happyReduce_40 = happyReduce 4# 17# happyReduction_40 -happyReduction_40 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_4 of { happy_var_4 -> - happyIn22 - (EAbs happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_41 = happySpecReduce_3 17# happyReduction_41 -happyReduction_41 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_2 of { happy_var_2 -> - happyIn22 - (EEq (reverse happy_var_2) - )} - -happyReduce_42 = happySpecReduce_1 17# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn22 - (happy_var_1 - )} - -happyReduce_43 = happySpecReduce_1 18# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn23 - (EAtom happy_var_1 - )} - -happyReduce_44 = happySpecReduce_1 18# happyReduction_44 -happyReduction_44 happy_x_1 - = happyIn23 - (EData - ) - -happyReduce_45 = happySpecReduce_3 18# happyReduction_45 -happyReduction_45 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut22 happy_x_2 of { happy_var_2 -> - happyIn23 - (happy_var_2 - )} - -happyReduce_46 = happySpecReduce_1 19# happyReduction_46 -happyReduction_46 happy_x_1 - = happyIn24 - (SType - ) - -happyReduce_47 = happySpecReduce_3 20# happyReduction_47 -happyReduction_47 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn25 - (Equ (reverse happy_var_1) happy_var_3 - )}} - -happyReduce_48 = happyReduce 4# 21# happyReduction_48 -happyReduction_48 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut20 happy_x_2 of { happy_var_2 -> - case happyOut28 happy_x_3 of { happy_var_3 -> - happyIn26 - (APC happy_var_2 (reverse happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_49 = happySpecReduce_1 21# happyReduction_49 -happyReduction_49 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn26 - (APV happy_var_1 - )} - -happyReduce_50 = happySpecReduce_1 21# happyReduction_50 -happyReduction_50 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn26 - (APS happy_var_1 - )} - -happyReduce_51 = happySpecReduce_1 21# happyReduction_51 -happyReduction_51 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn26 - (API happy_var_1 - )} - -happyReduce_52 = happySpecReduce_1 21# happyReduction_52 -happyReduction_52 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn26 - (APF happy_var_1 - )} - -happyReduce_53 = happySpecReduce_1 21# happyReduction_53 -happyReduction_53 happy_x_1 - = happyIn26 - (APW - ) - -happyReduce_54 = happySpecReduce_0 22# happyReduction_54 -happyReduction_54 = happyIn27 - ([] - ) - -happyReduce_55 = happySpecReduce_1 22# happyReduction_55 -happyReduction_55 happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn27 - ((:[]) happy_var_1 - )} - -happyReduce_56 = happySpecReduce_3 22# happyReduction_56 -happyReduction_56 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - case happyOut27 happy_x_3 of { happy_var_3 -> - happyIn27 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_57 = happySpecReduce_0 23# happyReduction_57 -happyReduction_57 = happyIn28 - ([] - ) - -happyReduce_58 = happySpecReduce_2 23# happyReduction_58 -happyReduction_58 happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut26 happy_x_2 of { happy_var_2 -> - happyIn28 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_59 = happySpecReduce_0 24# happyReduction_59 -happyReduction_59 = happyIn29 - ([] - ) - -happyReduce_60 = happySpecReduce_3 24# happyReduction_60 -happyReduction_60 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn29 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_61 = happySpecReduce_1 25# happyReduction_61 -happyReduction_61 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn30 - (AC happy_var_1 - )} - -happyReduce_62 = happySpecReduce_3 25# happyReduction_62 -happyReduction_62 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_2 of { happy_var_2 -> - happyIn30 - (AD happy_var_2 - )} - -happyReduce_63 = happySpecReduce_2 25# happyReduction_63 -happyReduction_63 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_2 of { happy_var_2 -> - happyIn30 - (AV happy_var_2 - )} - -happyReduce_64 = happySpecReduce_2 25# happyReduction_64 -happyReduction_64 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn30 - (AM happy_var_2 - )} - -happyReduce_65 = happySpecReduce_1 25# happyReduction_65 -happyReduction_65 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn30 - (AS happy_var_1 - )} - -happyReduce_66 = happySpecReduce_1 25# happyReduction_66 -happyReduction_66 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn30 - (AI happy_var_1 - )} - -happyReduce_67 = happySpecReduce_1 25# happyReduction_67 -happyReduction_67 happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - happyIn30 - (AT happy_var_1 - )} - -happyReduce_68 = happySpecReduce_3 26# happyReduction_68 -happyReduction_68 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn31 - (Decl happy_var_1 happy_var_3 - )}} - -happyReduce_69 = happySpecReduce_3 27# happyReduction_69 -happyReduction_69 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut52 happy_x_2 of { happy_var_2 -> - happyIn32 - (RecType happy_var_2 - )} - -happyReduce_70 = happyReduce 5# 27# happyReduction_70 -happyReduction_70 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut32 happy_x_4 of { happy_var_4 -> - happyIn32 - (Table happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_71 = happySpecReduce_1 27# happyReduction_71 -happyReduction_71 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn32 - (Cn happy_var_1 - )} - -happyReduce_72 = happySpecReduce_1 27# happyReduction_72 -happyReduction_72 happy_x_1 - = happyIn32 - (TStr - ) - -happyReduce_73 = happySpecReduce_2 27# happyReduction_73 -happyReduction_73 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn32 - (TInts happy_var_2 - )} - -happyReduce_74 = happySpecReduce_3 28# happyReduction_74 -happyReduction_74 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut32 happy_x_3 of { happy_var_3 -> - happyIn33 - (Lbg happy_var_1 happy_var_3 - )}} - -happyReduce_75 = happySpecReduce_1 29# happyReduction_75 -happyReduction_75 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn34 - (Arg happy_var_1 - )} - -happyReduce_76 = happySpecReduce_1 29# happyReduction_76 -happyReduction_76 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn34 - (I happy_var_1 - )} - -happyReduce_77 = happyReduce 4# 29# happyReduction_77 -happyReduction_77 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut20 happy_x_2 of { happy_var_2 -> - case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn34 - (Par happy_var_2 (reverse happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_78 = happySpecReduce_2 29# happyReduction_78 -happyReduction_78 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_2 of { happy_var_2 -> - happyIn34 - (LI happy_var_2 - )} - -happyReduce_79 = happySpecReduce_3 29# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn34 - (R happy_var_2 - )} - -happyReduce_80 = happySpecReduce_1 29# happyReduction_80 -happyReduction_80 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn34 - (EInt happy_var_1 - )} - -happyReduce_81 = happySpecReduce_1 29# happyReduction_81 -happyReduction_81 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn34 - (EFloat happy_var_1 - )} - -happyReduce_82 = happySpecReduce_1 29# happyReduction_82 -happyReduction_82 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn34 - (K happy_var_1 - )} - -happyReduce_83 = happySpecReduce_2 29# happyReduction_83 -happyReduction_83 happy_x_2 - happy_x_1 - = happyIn34 - (E - ) - -happyReduce_84 = happySpecReduce_3 29# happyReduction_84 -happyReduction_84 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut36 happy_x_2 of { happy_var_2 -> - happyIn34 - (happy_var_2 - )} - -happyReduce_85 = happySpecReduce_3 30# happyReduction_85 -happyReduction_85 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_3 of { happy_var_3 -> - happyIn35 - (P happy_var_1 happy_var_3 - )}} - -happyReduce_86 = happyReduce 5# 30# happyReduction_86 -happyReduction_86 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut53 happy_x_4 of { happy_var_4 -> - happyIn35 - (T happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_87 = happyReduce 5# 30# happyReduction_87 -happyReduction_87 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut54 happy_x_4 of { happy_var_4 -> - happyIn35 - (V happy_var_2 (reverse happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_88 = happySpecReduce_3 30# happyReduction_88 -happyReduction_88 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn35 - (S happy_var_1 happy_var_3 - )}} - -happyReduce_89 = happyReduce 4# 30# happyReduction_89 -happyReduction_89 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn35 - (FV (reverse happy_var_3) - ) `HappyStk` happyRest} - -happyReduce_90 = happySpecReduce_1 30# happyReduction_90 -happyReduction_90 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - happyIn35 - (happy_var_1 - )} - -happyReduce_91 = happySpecReduce_3 31# happyReduction_91 -happyReduction_91 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - case happyOut35 happy_x_3 of { happy_var_3 -> - happyIn36 - (C happy_var_1 happy_var_3 - )}} - -happyReduce_92 = happySpecReduce_1 31# happyReduction_92 -happyReduction_92 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn36 - (happy_var_1 - )} - -happyReduce_93 = happySpecReduce_1 32# happyReduction_93 -happyReduction_93 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn37 - (KS happy_var_1 - )} - -happyReduce_94 = happyReduce 7# 32# happyReduction_94 -happyReduction_94 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut55 happy_x_3 of { happy_var_3 -> - case happyOut56 happy_x_5 of { happy_var_5 -> - happyIn37 - (KP (reverse happy_var_3) happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_95 = happySpecReduce_3 33# happyReduction_95 -happyReduction_95 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn38 - (Ass happy_var_1 happy_var_3 - )}} - -happyReduce_96 = happySpecReduce_3 34# happyReduction_96 -happyReduction_96 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn39 - (Cas (reverse happy_var_1) happy_var_3 - )}} - -happyReduce_97 = happySpecReduce_3 35# happyReduction_97 -happyReduction_97 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn40 - (Var (reverse happy_var_1) (reverse happy_var_3) - )}} - -happyReduce_98 = happySpecReduce_1 36# happyReduction_98 -happyReduction_98 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn41 - (L happy_var_1 - )} - -happyReduce_99 = happySpecReduce_2 36# happyReduction_99 -happyReduction_99 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn41 - (LV happy_var_2 - )} - -happyReduce_100 = happySpecReduce_3 37# happyReduction_100 -happyReduction_100 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut7 happy_x_3 of { happy_var_3 -> - happyIn42 - (A happy_var_1 happy_var_3 - )}} - -happyReduce_101 = happyReduce 5# 37# happyReduction_101 -happyReduction_101 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut7 happy_x_3 of { happy_var_3 -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn42 - (AB happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_102 = happyReduce 4# 38# happyReduction_102 -happyReduction_102 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut20 happy_x_2 of { happy_var_2 -> - case happyOut58 happy_x_3 of { happy_var_3 -> - happyIn43 - (PC happy_var_2 (reverse happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_103 = happySpecReduce_1 38# happyReduction_103 -happyReduction_103 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn43 - (PV happy_var_1 - )} - -happyReduce_104 = happySpecReduce_1 38# happyReduction_104 -happyReduction_104 happy_x_1 - = happyIn43 - (PW - ) - -happyReduce_105 = happySpecReduce_3 38# happyReduction_105 -happyReduction_105 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut57 happy_x_2 of { happy_var_2 -> - happyIn43 - (PR happy_var_2 - )} - -happyReduce_106 = happySpecReduce_1 38# happyReduction_106 -happyReduction_106 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn43 - (PI happy_var_1 - )} - -happyReduce_107 = happySpecReduce_1 38# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn43 - (PF happy_var_1 - )} - -happyReduce_108 = happySpecReduce_3 39# happyReduction_108 -happyReduction_108 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_3 of { happy_var_3 -> - happyIn44 - (PAss happy_var_1 happy_var_3 - )}} - -happyReduce_109 = happySpecReduce_0 40# happyReduction_109 -happyReduction_109 = happyIn45 - ([] - ) - -happyReduce_110 = happySpecReduce_3 40# happyReduction_110 -happyReduction_110 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn45 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_111 = happySpecReduce_0 41# happyReduction_111 -happyReduction_111 = happyIn46 - ([] - ) - -happyReduce_112 = happySpecReduce_3 41# happyReduction_112 -happyReduction_112 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn46 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_113 = happySpecReduce_0 42# happyReduction_113 -happyReduction_113 = happyIn47 - ([] - ) - -happyReduce_114 = happySpecReduce_1 42# happyReduction_114 -happyReduction_114 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn47 - ((:[]) happy_var_1 - )} - -happyReduce_115 = happySpecReduce_3 42# happyReduction_115 -happyReduction_115 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn47 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_116 = happySpecReduce_0 43# happyReduction_116 -happyReduction_116 = happyIn48 - ([] - ) - -happyReduce_117 = happySpecReduce_2 43# happyReduction_117 -happyReduction_117 happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn48 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_118 = happySpecReduce_0 44# happyReduction_118 -happyReduction_118 = happyIn49 - ([] - ) - -happyReduce_119 = happySpecReduce_2 44# happyReduction_119 -happyReduction_119 happy_x_2 - happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { happy_var_2 -> - happyIn49 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_120 = happySpecReduce_0 45# happyReduction_120 -happyReduction_120 = happyIn50 - ([] - ) - -happyReduce_121 = happySpecReduce_1 45# happyReduction_121 -happyReduction_121 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - happyIn50 - ((:[]) happy_var_1 - )} - -happyReduce_122 = happySpecReduce_3 45# happyReduction_122 -happyReduction_122 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_123 = happySpecReduce_0 46# happyReduction_123 -happyReduction_123 = happyIn51 - ([] - ) - -happyReduce_124 = happySpecReduce_1 46# happyReduction_124 -happyReduction_124 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn51 - ((:[]) happy_var_1 - )} - -happyReduce_125 = happySpecReduce_3 46# happyReduction_125 -happyReduction_125 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_3 of { happy_var_3 -> - happyIn51 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_126 = happySpecReduce_0 47# happyReduction_126 -happyReduction_126 = happyIn52 - ([] - ) - -happyReduce_127 = happySpecReduce_1 47# happyReduction_127 -happyReduction_127 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn52 - ((:[]) happy_var_1 - )} - -happyReduce_128 = happySpecReduce_3 47# happyReduction_128 -happyReduction_128 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn52 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_129 = happySpecReduce_0 48# happyReduction_129 -happyReduction_129 = happyIn53 - ([] - ) - -happyReduce_130 = happySpecReduce_1 48# happyReduction_130 -happyReduction_130 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - happyIn53 - ((:[]) happy_var_1 - )} - -happyReduce_131 = happySpecReduce_3 48# happyReduction_131 -happyReduction_131 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_3 of { happy_var_3 -> - happyIn53 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_132 = happySpecReduce_0 49# happyReduction_132 -happyReduction_132 = happyIn54 - ([] - ) - -happyReduce_133 = happySpecReduce_2 49# happyReduction_133 -happyReduction_133 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn54 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_134 = happySpecReduce_0 50# happyReduction_134 -happyReduction_134 = happyIn55 - ([] - ) - -happyReduce_135 = happySpecReduce_2 50# happyReduction_135 -happyReduction_135 happy_x_2 - happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn55 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_136 = happySpecReduce_0 51# happyReduction_136 -happyReduction_136 = happyIn56 - ([] - ) - -happyReduce_137 = happySpecReduce_1 51# happyReduction_137 -happyReduction_137 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - happyIn56 - ((:[]) happy_var_1 - )} - -happyReduce_138 = happySpecReduce_3 51# happyReduction_138 -happyReduction_138 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut56 happy_x_3 of { happy_var_3 -> - happyIn56 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_139 = happySpecReduce_0 52# happyReduction_139 -happyReduction_139 = happyIn57 - ([] - ) - -happyReduce_140 = happySpecReduce_1 52# happyReduction_140 -happyReduction_140 happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - happyIn57 - ((:[]) happy_var_1 - )} - -happyReduce_141 = happySpecReduce_3 52# happyReduction_141 -happyReduction_141 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - case happyOut57 happy_x_3 of { happy_var_3 -> - happyIn57 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_142 = happySpecReduce_0 53# happyReduction_142 -happyReduction_142 = happyIn58 - ([] - ) - -happyReduce_143 = happySpecReduce_2 53# happyReduction_143 -happyReduction_143 happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - case happyOut43 happy_x_2 of { happy_var_2 -> - happyIn58 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_144 = happySpecReduce_0 54# happyReduction_144 -happyReduction_144 = happyIn59 - ([] - ) - -happyReduce_145 = happySpecReduce_1 54# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn59 - ((:[]) happy_var_1 - )} - -happyReduce_146 = happySpecReduce_3 54# happyReduction_146 -happyReduction_146 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - happyIn59 - ((:) happy_var_1 happy_var_3 - )}} - -happyNewToken action sts stk [] = - happyDoAction 54# (error "reading EOF!") action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS ";") -> cont 1#; - PT _ (TS "=") -> cont 2#; - PT _ (TS "{") -> cont 3#; - PT _ (TS "}") -> cont 4#; - PT _ (TS ":") -> cont 5#; - PT _ (TS "->") -> cont 6#; - PT _ (TS "**") -> cont 7#; - PT _ (TS "[") -> cont 8#; - PT _ (TS "]") -> cont 9#; - PT _ (TS "\\") -> cont 10#; - PT _ (TS ".") -> cont 11#; - PT _ (TS "(") -> cont 12#; - PT _ (TS ")") -> cont 13#; - PT _ (TS "_") -> cont 14#; - PT _ (TS "<") -> cont 15#; - PT _ (TS ">") -> cont 16#; - PT _ (TS "$") -> cont 17#; - PT _ (TS "?") -> cont 18#; - PT _ (TS "=>") -> cont 19#; - PT _ (TS "!") -> cont 20#; - PT _ (TS "++") -> cont 21#; - PT _ (TS "/") -> cont 22#; - PT _ (TS "@") -> cont 23#; - PT _ (TS "+") -> cont 24#; - PT _ (TS "|") -> cont 25#; - PT _ (TS ",") -> cont 26#; - PT _ (TS "Ints") -> cont 27#; - PT _ (TS "Str") -> cont 28#; - PT _ (TS "Type") -> cont 29#; - PT _ (TS "abstract") -> cont 30#; - PT _ (TS "cat") -> cont 31#; - PT _ (TS "concrete") -> cont 32#; - PT _ (TS "data") -> cont 33#; - PT _ (TS "flags") -> cont 34#; - PT _ (TS "fun") -> cont 35#; - PT _ (TS "grammar") -> cont 36#; - PT _ (TS "in") -> cont 37#; - PT _ (TS "lin") -> cont 38#; - PT _ (TS "lincat") -> cont 39#; - PT _ (TS "of") -> cont 40#; - PT _ (TS "open") -> cont 41#; - PT _ (TS "oper") -> cont 42#; - PT _ (TS "param") -> cont 43#; - PT _ (TS "pre") -> cont 44#; - PT _ (TS "resource") -> cont 45#; - PT _ (TS "table") -> cont 46#; - PT _ (TS "transfer") -> cont 47#; - PT _ (TS "variants") -> cont 48#; - PT _ (TV happy_dollar_dollar) -> cont 49#; - PT _ (TL happy_dollar_dollar) -> cont 50#; - PT _ (TI happy_dollar_dollar) -> cont 51#; - PT _ (TD happy_dollar_dollar) -> cont 52#; - _ -> cont 53#; - _ -> happyError' (tk:tks) - } - -happyError_ tk tks = happyError' (tk:tks) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = (thenM) -happyReturn :: () => a -> Err a -happyReturn = (returnM) -happyThen1 m k tks = (thenM) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (returnM) a -happyError' :: () => [Token] -> Err a -happyError' = happyError - -pCanon tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut9 x)) - -pLine tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut10 x)) - -happySeq = happyDontSeq - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) - -myLexer = tokens -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- $Id$ - - -{-# LINE 28 "GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - - -{-# LINE 49 "GenericTemplate.hs" #-} - - -{-# LINE 59 "GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - - - - - - - - - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 170 "GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/src-3.0/GF/Canon/ParGFC.y b/src-3.0/GF/Canon/ParGFC.y deleted file mode 100644 index 6432a8696..000000000 --- a/src-3.0/GF/Canon/ParGFC.y +++ /dev/null @@ -1,385 +0,0 @@ --- This Happy file was machine-generated by the BNF converter -{ -module GF.Canon.ParGFC where -import GF.Canon.AbsGFC -import GF.Canon.LexGFC -import GF.Data.ErrM -- H -import GF.Infra.Ident -- H -} - -%name pCanon Canon -%name pLine Line - --- no lexer declaration -%monad { Err } { thenM } { returnM } -%tokentype { Token } - -%token - ';' { PT _ (TS ";") } - '=' { PT _ (TS "=") } - '{' { PT _ (TS "{") } - '}' { PT _ (TS "}") } - ':' { PT _ (TS ":") } - '->' { PT _ (TS "->") } - '**' { PT _ (TS "**") } - '[' { PT _ (TS "[") } - ']' { PT _ (TS "]") } - '\\' { PT _ (TS "\\") } - '.' { PT _ (TS ".") } - '(' { PT _ (TS "(") } - ')' { PT _ (TS ")") } - '_' { PT _ (TS "_") } - '<' { PT _ (TS "<") } - '>' { PT _ (TS ">") } - '$' { PT _ (TS "$") } - '?' { PT _ (TS "?") } - '=>' { PT _ (TS "=>") } - '!' { PT _ (TS "!") } - '++' { PT _ (TS "++") } - '/' { PT _ (TS "/") } - '@' { PT _ (TS "@") } - '+' { PT _ (TS "+") } - '|' { PT _ (TS "|") } - ',' { PT _ (TS ",") } - 'Ints' { PT _ (TS "Ints") } - 'Str' { PT _ (TS "Str") } - 'Type' { PT _ (TS "Type") } - 'abstract' { PT _ (TS "abstract") } - 'cat' { PT _ (TS "cat") } - 'concrete' { PT _ (TS "concrete") } - 'data' { PT _ (TS "data") } - 'flags' { PT _ (TS "flags") } - 'fun' { PT _ (TS "fun") } - 'grammar' { PT _ (TS "grammar") } - 'in' { PT _ (TS "in") } - 'lin' { PT _ (TS "lin") } - 'lincat' { PT _ (TS "lincat") } - 'of' { PT _ (TS "of") } - 'open' { PT _ (TS "open") } - 'oper' { PT _ (TS "oper") } - 'param' { PT _ (TS "param") } - 'pre' { PT _ (TS "pre") } - 'resource' { PT _ (TS "resource") } - 'table' { PT _ (TS "table") } - 'transfer' { PT _ (TS "transfer") } - 'variants' { PT _ (TS "variants") } - -L_ident { PT _ (TV $$) } -L_quoted { PT _ (TL $$) } -L_integ { PT _ (TI $$) } -L_err { _ } - - -%% - -Ident :: { Ident } : L_ident { identC $1 } -- H -String :: { String } : L_quoted { $1 } -Integer :: { Integer } : L_integ { (read $1) :: Integer } - -Canon :: { Canon } -Canon : 'grammar' ListIdent 'of' Ident ';' ListModule { MGr $2 $4 (reverse $6) } - | ListModule { Gr (reverse $1) } - - -Line :: { Line } -Line : 'grammar' ListIdent 'of' Ident ';' { LMulti $2 $4 } - | ModType '=' Extend Open '{' { LHeader $1 $3 $4 } - | Flag ';' { LFlag $1 } - | Def ';' { LDef $1 } - | '}' { LEnd } - - -Module :: { Module } -Module : ModType '=' Extend Open '{' ListFlag ListDef '}' { Mod $1 $3 $4 (reverse $6) (reverse $7) } - - -ModType :: { ModType } -ModType : 'abstract' Ident { MTAbs $2 } - | 'concrete' Ident 'of' Ident { MTCnc $2 $4 } - | 'resource' Ident { MTRes $2 } - | 'transfer' Ident ':' Ident '->' Ident { MTTrans $2 $4 $6 } - - -ListModule :: { [Module] } -ListModule : {- empty -} { [] } - | ListModule Module { flip (:) $1 $2 } - - -Extend :: { Extend } -Extend : ListIdent '**' { Ext $1 } - | {- empty -} { NoExt } - - -Open :: { Open } -Open : 'open' ListIdent 'in' { Opens $2 } - | {- empty -} { NoOpens } - - -Flag :: { Flag } -Flag : 'flags' Ident '=' Ident { Flg $2 $4 } - - -Def :: { Def } -Def : 'cat' Ident '[' ListDecl ']' '=' ListCIdent { AbsDCat $2 $4 (reverse $7) } - | 'fun' Ident ':' Exp '=' Exp { AbsDFun $2 $4 $6 } - | 'transfer' Ident '=' Exp { AbsDTrans $2 $4 } - | 'param' Ident '=' ListParDef { ResDPar $2 $4 } - | 'oper' Ident ':' CType '=' Term { ResDOper $2 $4 $6 } - | 'lincat' Ident '=' CType '=' Term ';' Term { CncDCat $2 $4 $6 $8 } - | 'lin' Ident ':' CIdent '=' '\\' ListArgVar '->' Term ';' Term { CncDFun $2 $4 $7 $9 $11 } - | Ident Status 'in' Ident { AnyDInd $1 $2 $4 } - - -ParDef :: { ParDef } -ParDef : Ident ListCType { ParD $1 (reverse $2) } - - -Status :: { Status } -Status : 'data' { Canon } - | {- empty -} { NonCan } - - -CIdent :: { CIdent } -CIdent : Ident '.' Ident { CIQ $1 $3 } - - -Exp1 :: { Exp } -Exp1 : Exp1 Exp2 { EApp $1 $2 } - | Exp2 { $1 } - - -Exp :: { Exp } -Exp : '(' Ident ':' Exp ')' '->' Exp { EProd $2 $4 $7 } - | '\\' Ident '->' Exp { EAbs $2 $4 } - | '{' ListEquation '}' { EEq (reverse $2) } - | Exp1 { $1 } - - -Exp2 :: { Exp } -Exp2 : Atom { EAtom $1 } - | 'data' { EData } - | '(' Exp ')' { $2 } - - -Sort :: { Sort } -Sort : 'Type' { SType } - - -Equation :: { Equation } -Equation : ListAPatt '->' Exp { Equ (reverse $1) $3 } - - -APatt :: { APatt } -APatt : '(' CIdent ListAPatt ')' { APC $2 (reverse $3) } - | Ident { APV $1 } - | String { APS $1 } - | Integer { API $1 } - | '_' { APW } - - -ListDecl :: { [Decl] } -ListDecl : {- empty -} { [] } - | Decl { (:[]) $1 } - | Decl ';' ListDecl { (:) $1 $3 } - - -ListAPatt :: { [APatt] } -ListAPatt : {- empty -} { [] } - | ListAPatt APatt { flip (:) $1 $2 } - - -ListEquation :: { [Equation] } -ListEquation : {- empty -} { [] } - | ListEquation Equation ';' { flip (:) $1 $2 } - - -Atom :: { Atom } -Atom : CIdent { AC $1 } - | '<' CIdent '>' { AD $2 } - | '$' Ident { AV $2 } - | '?' Integer { AM $2 } - | String { AS $1 } - | Integer { AI $1 } - | Sort { AT $1 } - - -Decl :: { Decl } -Decl : Ident ':' Exp { Decl $1 $3 } - - -CType :: { CType } -CType : '{' ListLabelling '}' { RecType $2 } - | '(' CType '=>' CType ')' { Table $2 $4 } - | CIdent { Cn $1 } - | 'Str' { TStr } - | 'Ints' Integer { TInts $2 } - - -Labelling :: { Labelling } -Labelling : Label ':' CType { Lbg $1 $3 } - - -Term2 :: { Term } -Term2 : ArgVar { Arg $1 } - | CIdent { I $1 } - | '<' CIdent ListTerm2 '>' { Par $2 (reverse $3) } - | '$' Ident { LI $2 } - | '{' ListAssign '}' { R $2 } - | Integer { EInt $1 } - | Tokn { K $1 } - | '[' ']' { E } - | '(' Term ')' { $2 } - - -Term1 :: { Term } -Term1 : Term2 '.' Label { P $1 $3 } - | 'table' CType '{' ListCase '}' { T $2 $4 } - | 'table' CType '[' ListTerm2 ']' { V $2 (reverse $4) } - | Term1 '!' Term2 { S $1 $3 } - | 'variants' '{' ListTerm2 '}' { FV (reverse $3) } - | Term2 { $1 } - - -Term :: { Term } -Term : Term '++' Term1 { C $1 $3 } - | Term1 { $1 } - - -Tokn :: { Tokn } -Tokn : String { KS $1 } - | '[' 'pre' ListString '{' ListVariant '}' ']' { KP (reverse $3) $5 } - - -Assign :: { Assign } -Assign : Label '=' Term { Ass $1 $3 } - - -Case :: { Case } -Case : ListPatt '=>' Term { Cas (reverse $1) $3 } - - -Variant :: { Variant } -Variant : ListString '/' ListString { Var (reverse $1) (reverse $3) } - - -Label :: { Label } -Label : Ident { L $1 } - | '$' Integer { LV $2 } - - -ArgVar :: { ArgVar } -ArgVar : Ident '@' Integer { A $1 $3 } - | Ident '+' Integer '@' Integer { AB $1 $3 $5 } - - -Patt :: { Patt } -Patt : '(' CIdent ListPatt ')' { PC $2 (reverse $3) } - | Ident { PV $1 } - | '_' { PW } - | '{' ListPattAssign '}' { PR $2 } - | Integer { PI $1 } - - -PattAssign :: { PattAssign } -PattAssign : Label '=' Patt { PAss $1 $3 } - - -ListFlag :: { [Flag] } -ListFlag : {- empty -} { [] } - | ListFlag Flag ';' { flip (:) $1 $2 } - - -ListDef :: { [Def] } -ListDef : {- empty -} { [] } - | ListDef Def ';' { flip (:) $1 $2 } - - -ListParDef :: { [ParDef] } -ListParDef : {- empty -} { [] } - | ParDef { (:[]) $1 } - | ParDef '|' ListParDef { (:) $1 $3 } - - -ListCType :: { [CType] } -ListCType : {- empty -} { [] } - | ListCType CType { flip (:) $1 $2 } - - -ListCIdent :: { [CIdent] } -ListCIdent : {- empty -} { [] } - | ListCIdent CIdent { flip (:) $1 $2 } - - -ListAssign :: { [Assign] } -ListAssign : {- empty -} { [] } - | Assign { (:[]) $1 } - | Assign ';' ListAssign { (:) $1 $3 } - - -ListArgVar :: { [ArgVar] } -ListArgVar : {- empty -} { [] } - | ArgVar { (:[]) $1 } - | ArgVar ',' ListArgVar { (:) $1 $3 } - - -ListLabelling :: { [Labelling] } -ListLabelling : {- empty -} { [] } - | Labelling { (:[]) $1 } - | Labelling ';' ListLabelling { (:) $1 $3 } - - -ListCase :: { [Case] } -ListCase : {- empty -} { [] } - | Case { (:[]) $1 } - | Case ';' ListCase { (:) $1 $3 } - - -ListTerm2 :: { [Term] } -ListTerm2 : {- empty -} { [] } - | ListTerm2 Term2 { flip (:) $1 $2 } - - -ListString :: { [String] } -ListString : {- empty -} { [] } - | ListString String { flip (:) $1 $2 } - - -ListVariant :: { [Variant] } -ListVariant : {- empty -} { [] } - | Variant { (:[]) $1 } - | Variant ';' ListVariant { (:) $1 $3 } - - -ListPattAssign :: { [PattAssign] } -ListPattAssign : {- empty -} { [] } - | PattAssign { (:[]) $1 } - | PattAssign ';' ListPattAssign { (:) $1 $3 } - - -ListPatt :: { [Patt] } -ListPatt : {- empty -} { [] } - | ListPatt Patt { flip (:) $1 $2 } - - -ListIdent :: { [Ident] } -ListIdent : {- empty -} { [] } - | Ident { (:[]) $1 } - | Ident ',' ListIdent { (:) $1 $3 } - - - -{ - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) - -myLexer = tokens -} - diff --git a/src-3.0/GF/Canon/PrExp.hs b/src-3.0/GF/Canon/PrExp.hs deleted file mode 100644 index 6202a760e..000000000 --- a/src-3.0/GF/Canon/PrExp.hs +++ /dev/null @@ -1,46 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrExp --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:28 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- print trees without qualifications ------------------------------------------------------------------------------ - -module GF.Canon.PrExp (prExp) where - -import GF.Canon.AbsGFC -import GF.Canon.GFC - -import GF.Data.Operations - -prExp :: Exp -> String -prExp e = case e of - EApp f a -> pr1 f +++ pr2 a - EAbsR x b -> "\\" ++ prtt x +++ "->" +++ prExp b - EAbs x _ b -> prExp $ EAbsR x b - EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b - EAtomR a -> prAtom a - EAtom a _ -> prAtom a - _ -> prtt e - where - pr1 e = case e of - EAbsR _ _ -> prParenth $ prExp e - EAbs _ _ _ -> prParenth $ prExp e - EProd _ _ _ -> prParenth $ prExp e - _ -> prExp e - pr2 e = case e of - EApp _ _ -> prParenth $ prExp e - _ -> pr1 e - -prAtom a = case a of - AC c -> prCIdent c - AD c -> prCIdent c - _ -> prtt a - -prCIdent (CIQ _ c) = prtt c diff --git a/src-3.0/GF/Canon/PrintGFC.hs b/src-3.0/GF/Canon/PrintGFC.hs deleted file mode 100644 index 437f3a1e9..000000000 --- a/src-3.0/GF/Canon/PrintGFC.hs +++ /dev/null @@ -1,376 +0,0 @@ -module GF.Canon.PrintGFC where - - --- pretty-printer generated by the BNF converter, except handhacked spacing --H - -import GF.Infra.Ident --H -import GF.Canon.AbsGFC -import Data.Char - --- the top-level printing method -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -docs :: ShowS -> Doc -docs x y = concatD [spc, doc x, spc ] y - -spc = doc (showString "&") - -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - "*" :ts -> realnew . rend i ts --H - "&":"&":ts -> showChar ' ' . rend i ts --H - "&" :ts -> rend i ts --H - t :ts -> showString t . rend i ts - _ -> id - realnew = showChar '\n' --H - -{- -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - "*NEW" :ts -> realnew . rend i ts --H - "<" :ts -> showString "<" . rend i ts --H - "$" :ts -> showString "$" . rend i ts --H - "?" :ts -> showString "?" . rend i ts --H - "[" :ts -> showChar '[' . rend i ts - "(" :ts -> showChar '(' . rend i ts - "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts - "}" : ";":ts -> new (i-1) . showChar '}' . showChar ';' . new (i-1) . rend (i-1) ts - "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts - ";" :ts -> showChar ';' . new i . rend i ts - t : "@" :ts -> showString t . showChar '@' . rend i ts - t : "," :ts -> showString t . showChar ',' . rend i ts - t : ")" :ts -> showString t . showChar ')' . rend i ts - t : "]" :ts -> showString t . showChar ']' . rend i ts - t : ">" :ts -> showString t . showChar '>' . rend i ts --H - t : "." :ts -> showString t . showChar '.' . rend i ts --H - t@"=>" :ts -> showString t . rend i ts --H - t@"->" :ts -> showString t . rend i ts --H - t :ts -> realspace t . rend i ts --H - _ -> id - space t = showString t . showChar ' ' -- H - realspace t = showString t . (\s -> if null s then "" else (' ':s)) -- H - new i s = s -- H - realnew = showChar '\n' --H --} - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- the printer class does the job -class Print a where - prt :: Int -> a -> Doc - prtList :: [a] -> Doc - prtList = concatD . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') - prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q s = case s of - _ | s == q -> showChar '\\' . showChar s - '\\'-> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - _ -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Canon where - prt i e = case e of - MGr ids id modules -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc , doc (showString "of") , spc, prt 0 id , doc (showString ";") , prt 0 modules]) - Gr modules -> prPrec i 0 (concatD [prt 0 modules]) - - -instance Print Line where - prt i e = case e of - LMulti ids id -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc, doc (showString "of") , spc, prt 0 id , doc (showString ";")]) - LHeader modtype extend open -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{")]) - LFlag flag -> prPrec i 0 (concatD [prt 0 flag , doc (showString ";")]) - LDef def -> prPrec i 0 (concatD [prt 0 def , doc (showString ";")]) - LEnd -> prPrec i 0 (concatD [doc (showString "}")]) - - -instance Print Module where - prt i e = case e of - Mod modtype extend open flags defs -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{") , prt 0 flags , prt 0 defs , doc (showString "}")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print ModType where - prt i e = case e of - MTAbs id -> prPrec i 0 (concatD [spc, doc (showString "abstract") , spc , prt 0 id]) - MTCnc id0 id -> prPrec i 0 (concatD [spc, doc (showString "concrete") , spc, prt 0 id0 , spc, doc (showString "of") , spc, prt 0 id]) - MTRes id -> prPrec i 0 (concatD [spc, doc (showString "resource") , spc, prt 0 id]) - MTTrans id0 id1 id -> prPrec i 0 (concatD [spc, doc (showString "transfer") , spc, prt 0 id0 , doc (showString ":") , prt 0 id1 , doc (showString "->") , prt 0 id]) - - -instance Print Extend where - prt i e = case e of - Ext ids -> prPrec i 0 (concatD [prt 0 ids , doc (showString "**")]) - NoExt -> prPrec i 0 (concatD []) - - -instance Print Open where - prt i e = case e of - Opens ids -> prPrec i 0 (concatD [spc, doc (showString "open") , spc, prt 0 ids , docs (showString "in")]) - NoOpens -> prPrec i 0 (concatD []) - - -instance Print Flag where - prt i e = case e of - Flg id0 id -> prPrec i 0 (concatD [spc, doc (showString "flags") , spc, prt 0 id0 , doc (showString "=") , prt 0 id]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Def where - prt i e = case e of - AbsDCat id decls cidents -> prPrec i 0 (concatD [docs (showString "cat") , prt 0 id , doc (showString "[") , prt 0 decls , doc (showString "]") , doc (showString "=") , prt 0 cidents]) - AbsDFun id exp0 exp -> prPrec i 0 (concatD [docs (showString "fun") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - AbsDTrans id exp -> prPrec i 0 (concatD [docs (showString "transfer") , prt 0 id , doc (showString "=") , prt 0 exp]) - ResDPar id pardefs -> prPrec i 0 (concatD [docs (showString "param") , prt 0 id , doc (showString "=") , prt 0 pardefs]) - ResDOper id ctype term -> prPrec i 0 (concatD [docs (showString "oper") , prt 0 id , doc (showString ":") , prt 0 ctype , doc (showString "=") , prt 0 term]) - CncDCat id ctype term0 term -> prPrec i 0 (concatD [docs (showString "lincat") , prt 0 id , doc (showString "=") , prt 0 ctype , doc (showString "=") , prt 0 term0 , doc (showString ";") , prt 0 term]) - CncDFun id cident argvars term0 term -> prPrec i 0 (concatD [docs (showString "lin") , prt 0 id , doc (showString ":") , prt 0 cident , doc (showString "=") , doc (showString "\\") , prt 0 argvars , doc (showString "->") , prt 0 term0 , doc (showString ";") , prt 0 term]) - AnyDInd id0 status id -> prPrec i 0 (concatD [prt 0 id0 , prt 0 status , docs (showString "in") , prt 0 id]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString ";"), doc (showString "*") , prt 0 xs]) -- H - - -instance Print ParDef where - prt i e = case e of - ParD id ctypes -> prPrec i 0 (concatD [prt 0 id , prt 0 ctypes]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print Status where - prt i e = case e of - Canon -> prPrec i 0 (concatD [docs (showString "data")]) - NonCan -> prPrec i 0 (concatD []) - - -instance Print CIdent where - prt i e = case e of - CIQ id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Exp where - prt i e = case e of - EApp exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , prt 2 exp]) - EProd id exp0 exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp]) - EAbs id exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 id , doc (showString "->") , prt 0 exp]) - EAtom atom -> prPrec i 2 (concatD [prt 0 atom]) - EData -> prPrec i 2 (concatD [docs (showString "data")]) - EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , doc (showString "}")]) - - -instance Print Sort where - prt i e = case e of - SType -> prPrec i 0 (concatD [docs (showString "Type")]) - - -instance Print Equation where - prt i e = case e of - Equ apatts exp -> prPrec i 0 (concatD [prt 0 apatts , doc (showString "->") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print APatt where - prt i e = case e of - APC cident apatts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 apatts , doc (showString ")")]) - APV id -> prPrec i 0 (concatD [prt 0 id]) - APS str -> prPrec i 0 (concatD [prt 0 str]) - API n -> prPrec i 0 (concatD [prt 0 n]) - APF n -> prPrec i 0 (concatD [prt 0 n]) - APW -> prPrec i 0 (concatD [doc (showString "_")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Atom where - prt i e = case e of - AC cident -> prPrec i 0 (concatD [prt 0 cident]) - AD cident -> prPrec i 0 (concatD [doc (showString "<") , prt 0 cident , doc (showString ">")]) - AV id -> prPrec i 0 (concatD [doc (showString "$") , prt 0 id]) - AM n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n]) - AS str -> prPrec i 0 (concatD [prt 0 str]) - AI n -> prPrec i 0 (concatD [prt 0 n]) - AT sort -> prPrec i 0 (concatD [prt 0 sort]) - - -instance Print Decl where - prt i e = case e of - Decl id exp -> prPrec i 0 (concatD [prt 0 id , doc (showString ":") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print CType where - prt i e = case e of - RecType labellings -> prPrec i 0 (concatD [doc (showString "{") , prt 0 labellings , doc (showString "}")]) - Table ctype0 ctype -> prPrec i 0 (concatD [doc (showString "(") , prt 0 ctype0 , doc (showString "=>") , prt 0 ctype , doc (showString ")")]) - Cn cident -> prPrec i 0 (concatD [prt 0 cident]) - TStr -> prPrec i 0 (concatD [docs (showString "Str")]) - TInts n -> prPrec i 0 (concatD [docs (showString "Ints") , prt 0 n]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Labelling where - prt i e = case e of - Lbg label ctype -> prPrec i 0 (concatD [prt 0 label , doc (showString ":") , prt 0 ctype]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Term where - prt i e = case e of - Arg argvar -> prPrec i 2 (concatD [prt 0 argvar]) - I cident -> prPrec i 2 (concatD [prt 0 cident]) - Par cident terms -> prPrec i 2 (concatD [doc (showString "<") , prt 0 cident , prt 2 terms , doc (showString ">")]) - LI id -> prPrec i 2 (concatD [doc (showString "$") , prt 0 id]) - R assigns -> prPrec i 2 (concatD [doc (showString "{") , prt 0 assigns , doc (showString "}")]) - P term label -> prPrec i 1 (concatD [prt 2 term , doc (showString ".") , prt 0 label]) - T ctype cases -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "{") , prt 0 cases , doc (showString "}")]) - V ctype terms -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "[") , prt 2 terms , doc (showString "]")]) - S term0 term -> prPrec i 1 (concatD [prt 1 term0 , doc (showString "!") , prt 2 term]) - C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term]) - FV terms -> prPrec i 1 (concatD [docs (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")]) - EInt n -> prPrec i 2 (concatD [prt 0 n]) - EFloat n -> prPrec i 2 (concatD [prt 0 n]) - K tokn -> prPrec i 2 (concatD [prt 0 tokn]) - E -> prPrec i 2 (concatD [doc (showString "[") , doc (showString "]")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 2 x , prt 2 xs]) - -instance Print Tokn where - prt i e = case e of - KS str -> prPrec i 0 (concatD [prt 0 str]) - KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , docs (showString "pre") , prt 0 strs , doc (showString "{") , prt 0 variants , doc (showString "}") , doc (showString "]")]) - KM str -> prPrec i 0 (concatD [prt 0 str]) - - -instance Print Assign where - prt i e = case e of - Ass label term -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 term]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Case where - prt i e = case e of - Cas patts term -> prPrec i 0 (concatD [prt 0 patts , doc (showString "=>") , prt 0 term]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Variant where - prt i e = case e of - Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Label where - prt i e = case e of - L id -> prPrec i 0 (concatD [prt 0 id]) - LV n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n]) - - -instance Print ArgVar where - prt i e = case e of - A id n -> prPrec i 0 (concatD [prt 0 id , doc (showString "@") , prt 0 n]) - AB id n0 n -> prPrec i 0 (concatD [prt 0 id , doc (showString "+") , prt 0 n0 , doc (showString "@") , prt 0 n]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Patt where - prt i e = case e of - PC cident patts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 patts , doc (showString ")")]) - PV id -> prPrec i 0 (concatD [prt 0 id]) - PW -> prPrec i 0 (concatD [docs (showString "_")]) - PR pattassigns -> prPrec i 0 (concatD [doc (showString "{") , prt 0 pattassigns , doc (showString "}")]) - PI n -> prPrec i 0 (concatD [prt 0 n]) - PF n -> prPrec i 0 (concatD [prt 0 n]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print PattAssign where - prt i e = case e of - PAss label patt -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - - diff --git a/src-3.0/GF/Canon/Share.hs b/src-3.0/GF/Canon/Share.hs deleted file mode 100644 index 69725001a..000000000 --- a/src-3.0/GF/Canon/Share.hs +++ /dev/null @@ -1,147 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Share --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.12 $ --- --- Optimizations on GFC code: sharing, parametrization, value sets. --- --- optimization: sharing branches in tables. AR 25\/4\/2003. --- following advice of Josef Svenningsson ------------------------------------------------------------------------------ - -module GF.Canon.Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where - -import GF.Canon.AbsGFC -import GF.Infra.Ident -import GF.Canon.GFC -import qualified GF.Canon.CMacros as C -import GF.Grammar.PrGrammar (prt) -import GF.Data.Operations -import Data.List -import qualified GF.Infra.Modules as M - -type OptSpec = [Integer] --- - -doOptFactor opt = elem 2 opt -doOptValues opt = elem 3 opt - -shareOpt :: OptSpec -shareOpt = [] - -paramOpt :: OptSpec -paramOpt = [2] - -valOpt :: OptSpec -valOpt = [3] - -allOpt :: OptSpec -allOpt = [2,3] - -shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo) -shareModule opt (i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) -> - (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) - _ -> (i,m) - -shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m) -shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m) -shareInfo _ i = i - --- | the function putting together optimizations -shareOptim :: OptSpec -> Ident -> Term -> Term -shareOptim opt c - | doOptFactor opt && doOptValues opt = values . factor c 0 - | doOptFactor opt = share . factor c 0 - | doOptValues opt = values - | otherwise = share - --- | we need no counter to create new variable names, since variables are --- local to tables -share :: Term -> Term -share t = case t of - T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant. - R lts -> R [Ass l (share t) | Ass l t <- lts] - P t l -> P (share t) l - S t a -> S (share t) (share a) - C t a -> C (share t) (share a) - FV ts -> FV (map share ts) - - _ -> t -- including D, which is always born shared - - where - shareT ty = finalize ty . groupC . sortC - - sortC :: [(Patt,Term)] -> [(Patt,Term)] - sortC = sortBy $ \a b -> compare (snd a) (snd b) - - groupC :: [(Patt,Term)] -> [[(Patt,Term)]] - groupC = groupBy $ \a b -> snd a == snd b - - finalize :: CType -> [[(Patt,Term)]] -> Term - finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css] - - --- | do even more: factor parametric branches -factor :: Ident -> Int -> Term -> Term -factor c i t = case t of - T _ [_] -> t - T _ [] -> t - T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps] - R lts -> R [Ass l (factor c i t) | Ass l t <- lts] - P t l -> P (factor c i t) l - S t a -> S (factor c i t) (factor c i a) - C t a -> C (factor c i t) (factor c i a) - FV ts -> FV (map (factor c i) ts) - - _ -> t - where - - factors i psvs = -- we know psvs has at least 2 elements - let p = pIdent c i - vs' = map (mkFun p) psvs - in if allEqs vs' - then mkCase p vs' - else psvs - - mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val - - allEqs (v:vs) = all (==v) vs - - mkCase p (v:_) = [Cas [PV p] v] - -pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i) - - --- | we need to replace subterms -replace :: Term -> Term -> Term -> Term -replace old new trm = case trm of - T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs] - P t l -> P (repl t) l - S t a -> S (repl t) (repl a) - C t a -> C (repl t) (repl a) - FV ts -> FV (map repl ts) - - -- these are the important cases, since they can correspond to patterns - Par c ts | trm == old -> new - Par c ts -> Par c (map repl ts) - R _ | isRec && trm == old -> new - R lts -> R [Ass l (repl t) | Ass l t <- lts] - - _ -> trm - where - repl = replace old new - isRec = case trm of - R _ -> True - _ -> False - -values :: Term -> Term -values t = case t of - T ty [c] -> T ty [Cas p (values t) | Cas p t <- [c]] -- preserve parametrization - T ty cs -> V ty [values t | Cas _ t <- cs] -- assumes proper order - _ -> C.composSafeOp values t diff --git a/src-3.0/GF/Canon/SkelGFC.hs b/src-3.0/GF/Canon/SkelGFC.hs deleted file mode 100644 index a1d9331d8..000000000 --- a/src-3.0/GF/Canon/SkelGFC.hs +++ /dev/null @@ -1,217 +0,0 @@ -module GF.Canon.SkelGFC where - --- Haskell module generated by the BNF converter - -import GF.Canon.AbsGFC -import GF.Data.ErrM -import GF.Infra.Ident - -type Result = Err String - -failure :: Show a => a -> Result -failure x = Bad $ "Undefined case: " ++ show x - -transIdent :: Ident -> Result -transIdent x = case x of - Ident str -> failure x - - -transCanon :: Canon -> Result -transCanon x = case x of - MGr ids id modules -> failure x - Gr modules -> failure x - - -transLine :: Line -> Result -transLine x = case x of - LMulti ids id -> failure x - LHeader modtype extend open -> failure x - LFlag flag -> failure x - LDef def -> failure x - LEnd -> failure x - - -transModule :: Module -> Result -transModule x = case x of - Mod modtype extend open flags defs -> failure x - - -transModType :: ModType -> Result -transModType x = case x of - MTAbs id -> failure x - MTCnc id0 id -> failure x - MTRes id -> failure x - MTTrans id0 id1 id -> failure x - - -transExtend :: Extend -> Result -transExtend x = case x of - Ext ids -> failure x - NoExt -> failure x - - -transOpen :: Open -> Result -transOpen x = case x of - Opens ids -> failure x - NoOpens -> failure x - - -transFlag :: Flag -> Result -transFlag x = case x of - Flg id0 id -> failure x - - -transDef :: Def -> Result -transDef x = case x of - AbsDCat id decls cidents -> failure x - AbsDFun id exp0 exp -> failure x - AbsDTrans id exp -> failure x - ResDPar id pardefs -> failure x - ResDOper id ctype term -> failure x - CncDCat id ctype term0 term -> failure x - CncDFun id cident argvars term0 term -> failure x - AnyDInd id0 status id -> failure x - - -transParDef :: ParDef -> Result -transParDef x = case x of - ParD id ctypes -> failure x - - -transStatus :: Status -> Result -transStatus x = case x of - Canon -> failure x - NonCan -> failure x - - -transCIdent :: CIdent -> Result -transCIdent x = case x of - CIQ id0 id -> failure x - - -transExp :: Exp -> Result -transExp x = case x of - EApp exp0 exp -> failure x - EProd id exp0 exp -> failure x - EAbs id exp -> failure x - EAtom atom -> failure x - EData -> failure x - EEq equations -> failure x - - -transSort :: Sort -> Result -transSort x = case x of - SType -> failure x - - -transEquation :: Equation -> Result -transEquation x = case x of - Equ apatts exp -> failure x - - -transAPatt :: APatt -> Result -transAPatt x = case x of - APC cident apatts -> failure x - APV id -> failure x - APS str -> failure x - API n -> failure x - APW -> failure x - - -transAtom :: Atom -> Result -transAtom x = case x of - AC cident -> failure x - AD cident -> failure x - AV id -> failure x - AM n -> failure x - AS str -> failure x - AI n -> failure x - AT sort -> failure x - - -transDecl :: Decl -> Result -transDecl x = case x of - Decl id exp -> failure x - - -transCType :: CType -> Result -transCType x = case x of - RecType labellings -> failure x - Table ctype0 ctype -> failure x - Cn cident -> failure x - TStr -> failure x - TInts n -> failure x - - -transLabelling :: Labelling -> Result -transLabelling x = case x of - Lbg label ctype -> failure x - - -transTerm :: Term -> Result -transTerm x = case x of - Arg argvar -> failure x - I cident -> failure x - Par cident terms -> failure x - LI id -> failure x - R assigns -> failure x - P term label -> failure x - T ctype cases -> failure x - V ctype terms -> failure x - S term0 term -> failure x - C term0 term -> failure x - FV terms -> failure x - EInt n -> failure x - K tokn -> failure x - E -> failure x - - -transTokn :: Tokn -> Result -transTokn x = case x of - KS str -> failure x - KP strs variants -> failure x - KM str -> failure x - - -transAssign :: Assign -> Result -transAssign x = case x of - Ass label term -> failure x - - -transCase :: Case -> Result -transCase x = case x of - Cas patts term -> failure x - - -transVariant :: Variant -> Result -transVariant x = case x of - Var strs0 strs -> failure x - - -transLabel :: Label -> Result -transLabel x = case x of - L id -> failure x - LV n -> failure x - - -transArgVar :: ArgVar -> Result -transArgVar x = case x of - A id n -> failure x - AB id n0 n -> failure x - - -transPatt :: Patt -> Result -transPatt x = case x of - PC cident patts -> failure x - PV id -> failure x - PW -> failure x - PR pattassigns -> failure x - PI n -> failure x - - -transPattAssign :: PattAssign -> Result -transPattAssign x = case x of - PAss label patt -> failure x - - - diff --git a/src-3.0/GF/Canon/Subexpressions.hs b/src-3.0/GF/Canon/Subexpressions.hs deleted file mode 100644 index 683f9eecf..000000000 --- a/src-3.0/GF/Canon/Subexpressions.hs +++ /dev/null @@ -1,170 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Subexpressions --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/20 09:32:56 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.4 $ --- --- Common subexpression elimination. --- all tables. AR 18\/9\/2005. ------------------------------------------------------------------------------ - -module GF.Canon.Subexpressions ( - elimSubtermsMod, prSubtermStat, unSubelimCanon, unSubelimModule - ) where - -import GF.Canon.AbsGFC -import GF.Infra.Ident -import GF.Canon.GFC -import GF.Canon.Look -import GF.Grammar.PrGrammar -import GF.Canon.CMacros as C -import GF.Data.Operations -import qualified GF.Infra.Modules as M - -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List - -{- -This module implements a simple common subexpression elimination - for gfc grammars, to factor out shared subterms in lin rules. -It works in three phases: - - (1) collectSubterms collects recursively all subterms of forms table and (P x..y) - from lin definitions (experience shows that only these forms - tend to get shared) and counts how many times they occur - (2) addSubexpConsts takes those subterms t that occur more than once - and creates definitions of form "oper A''n = t" where n is a - fresh number; notice that we assume no ids of this form are in - scope otherwise - (3) elimSubtermsMod goes through lins and the created opers by replacing largest - possible subterms by the newly created identifiers - -The optimization is invoked in gf by the flag i -subs. - -If an application does not support GFC opers, the effect of this -optimization can be undone by the function unSubelimCanon. - -The function unSubelimCanon can be used to diagnostisize how much -cse is possible in the grammar. It is used by the flag pg -printer=subs. - --} - --- exported functions - -elimSubtermsMod :: (Ident,CanonModInfo) -> Err (Ident, CanonModInfo) -elimSubtermsMod (mo,m) = case m of - M.ModMod (M.Module mt st fs me ops js) -> do - (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js - return (mo,M.ModMod (M.Module mt st fs me ops js2)) - _ -> return (mo,m) - -prSubtermStat :: CanonGrammar -> String -prSubtermStat gr = unlines [prt mo ++++ expsIn mo js | (mo,js) <- mos] where - mos = [(i, tree2list (M.jments m)) | (i, M.ModMod m) <- M.modules gr, M.isModCnc m] - expsIn mo js = err id id $ do - (tree,_) <- appSTM (getSubtermsMod mo js) (Map.empty,0) - let list0 = Map.toList tree - let list1 = sortBy (\ (_,(m,_)) (_,(n,_)) -> compare n m) list0 - return $ unlines [show n ++ "\t" ++ prt trm | (trm,(n,_)) <- list1] - -unSubelimCanon :: CanonGrammar -> CanonGrammar -unSubelimCanon gr@(M.MGrammar modules) = - M.MGrammar $ map unSubelimModule modules - -unSubelimModule :: CanonModule -> CanonModule -unSubelimModule mo@(i,m) = case m of - M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) | hasSub ljs -> - (i, M.ModMod (M.Module mt st fs me ops - (rebuild (map unparInfo ljs)))) - where ljs = tree2list js - _ -> (i,m) - where - -- perform this iff the module has opers - hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] - unparInfo (c,info) = case info of - CncFun k xs t m -> [(c, CncFun k xs (unparTerm t) m)] - ResOper _ _ -> [] - _ -> [(c,info)] - unparTerm t = case t of - I c -> errVal t $ liftM unparTerm $ lookupGlobal gr c - _ -> C.composSafeOp unparTerm t - gr = M.MGrammar [mo] - rebuild = buildTree . concat - --- implementation - -type TermList = Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] -addSubexpConsts mo tree lins = do - let opers = [oper id trm | (trm,(_,id)) <- list] - mapM mkOne $ opers ++ lins - where - - mkOne (f,def) = case def of - CncFun ci xs trm pn -> do - trm' <- recomp f trm - return (f,CncFun ci xs trm' pn) - ResOper ty trm -> do - trm' <- recomp f trm - return (f,ResOper ty trm') - _ -> return (f,def) - recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> return $ I $ cident mo id - _ -> composOp (recomp f) t - - list = Map.toList tree - - oper id trm = (ident id, ResOper TStr trm) --- type TStr does not matter - -getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) -getSubtermsMod mo js = do - mapM (getInfo (collectSubterms mo)) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get fi@(f,i) = case i of - CncFun ci xs trm pn -> do - get trm - return $ fi - ResOper ty trm -> do - get trm - return $ fi - _ -> return fi - -collectSubterms :: Ident -> Term -> TermM Term -collectSubterms mo t = case t of - Par _ (_:_) -> add t - T ty cs -> do - let (ps,ts) = unzip [(p,t) | Cas p t <- cs] - mapM (collectSubterms mo) ts - add t - V ty ts -> do - mapM (collectSubterms mo) ts - add t - K (KP _ _) -> add t - _ -> composOp (collectSubterms mo) t - where - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - return t --- only because of composOp - -ident :: Int -> Ident -ident i = identC ("A''" ++ show i) --- - -cident :: Ident -> Int -> CIdent -cident mo = CIQ mo . ident diff --git a/src-3.0/GF/Canon/TestGFC.hs b/src-3.0/GF/Canon/TestGFC.hs deleted file mode 100644 index 7c89d64e8..000000000 --- a/src-3.0/GF/Canon/TestGFC.hs +++ /dev/null @@ -1,58 +0,0 @@ --- automatically generated by BNF Converter -module Main where - - -import IO ( stdin, hGetContents ) -import System ( getArgs, getProgName ) - -import GF.Canon.LexGFC -import GF.Canon.ParGFC -import GF.Canon.SkelGFC -import GF.Canon.PrintGFC -import GF.Canon.AbsGFC -import GF.Infra.Ident - - - -import GF.Data.ErrM - -type ParseFun a = [Token] -> Err a - -myLLexer = myLexer - -type Verbosity = Int - -putStrV :: Verbosity -> String -> IO () -putStrV v s = if v > 1 then putStrLn s else return () - -runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () -runFile v p f = putStrLn f >> readFile f >>= run v p - -run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () -run v p s = let ts = myLLexer s in case p ts of - Bad s -> do putStrLn "\nParse Failed...\n" - putStrV v "Tokens:" - putStrV v $ show ts - putStrLn s - Ok tree -> do putStrLn "\nParse Successful!" - showTree v tree - - - -showTree :: (Show a, Print a) => Int -> a -> IO () -showTree v tree - = do - putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree - putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree - -main :: IO () -main = do args <- getArgs - case args of - [] -> hGetContents stdin >>= run 2 pCanon - "-s":fs -> mapM_ (runFile 0 pCanon) fs - fs -> mapM_ (runFile 2 pCanon) fs - - - - - diff --git a/src-3.0/GF/Canon/Unlex.hs b/src-3.0/GF/Canon/Unlex.hs deleted file mode 100644 index dd93390e2..000000000 --- a/src-3.0/GF/Canon/Unlex.hs +++ /dev/null @@ -1,49 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Unlex --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:32 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- elementary text postprocessing. AR 21/11/2001 ------------------------------------------------------------------------------ - -module GF.Canon.Unlex (formatAsText, unlex, performBinds) where - -import GF.Data.Operations -import GF.Data.Str - -import Data.Char -import Data.List (isPrefixOf) - -formatAsText :: String -> String -formatAsText = unwords . format . cap . words where - format ws = case ws of - w : c : ww | major c -> (w ++ c) : format (cap ww) - w : c : ww | minor c -> (w ++ c) : format ww - c : ww | para c -> "\n\n" : format ww - w : ww -> w : format ww - [] -> [] - cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww - cap ((c:cs):ww) = (toUpper c : cs) : ww - cap [] = [] - major = flip elem (map (:[]) ".!?") - minor = flip elem (map (:[]) ",:;") - para = (=="&-") - -unlex :: [Str] -> String -unlex = formatAsText . performBinds . concat . map sstr . take 1 ---- - --- | modified from GF/src/Text by adding hyphen -performBinds :: String -> String -performBinds = unwords . format . words where - format ws = case ws of - w : "-" : u : ws -> format ((w ++ "-" ++ u) : ws) - w : "&+" : u : ws -> format ((w ++ u) : ws) - w : ws -> w : format ws - [] -> [] - diff --git a/src-3.0/GF/Canon/Unparametrize.hs b/src-3.0/GF/Canon/Unparametrize.hs deleted file mode 100644 index 0ca6a2d9c..000000000 --- a/src-3.0/GF/Canon/Unparametrize.hs +++ /dev/null @@ -1,63 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Unparametrize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/14 16:26:21 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.1 $ --- --- Taking away parameters from a canonical grammar. All param --- types are replaced by {}, and only one branch is left in --- all tables. AR 14\/9\/2005. ------------------------------------------------------------------------------ - -module GF.Canon.Unparametrize (unparametrizeCanon) where - -import GF.Canon.AbsGFC -import GF.Infra.Ident -import GF.Canon.GFC -import qualified GF.Canon.CMacros as C -import GF.Data.Operations -import qualified GF.Infra.Modules as M - -unparametrizeCanon :: CanonGrammar -> CanonGrammar -unparametrizeCanon (M.MGrammar modules) = - M.MGrammar $ map unparModule modules where - - unparModule (i,m) = case m of - M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) -> - let me' = [(unparIdent j,incl) | (j,incl) <- me] in - (unparIdent i, M.ModMod (M.Module mt st fs me' ops (mapTree unparInfo js))) - _ -> (i,m) - - unparInfo (c,info) = case info of - CncCat ty t m -> (c, CncCat (unparCType ty) (unparTerm t) m) - CncFun k xs t m -> (c, CncFun k xs (unparTerm t) m) - AnyInd b i -> (c, AnyInd b (unparIdent i)) - _ -> (c,info) - - unparCType ty = case ty of - RecType ls -> RecType [Lbg lab (unparCType t) | Lbg lab t <- ls] - Table _ v -> unparCType v --- Table unitType (unparCType v) - Cn _ -> unitType - _ -> ty - - unparTerm t = case t of - Par _ _ -> unitTerm - T _ cs -> unparTerm (head [t | Cas _ t <- cs]) - V _ ts -> unparTerm (head ts) - S t _ -> unparTerm t -{- - T _ cs -> V unitType [unparTerm (head [t | Cas _ t <- cs])] - V _ ts -> V unitType [unparTerm (head ts)] - S t _ -> S (unparTerm t) unitTerm --} - _ -> C.composSafeOp unparTerm t - - unitType = RecType [] - unitTerm = R [] - - unparIdent (IC s) = IC $ "UP_" ++ s diff --git a/src-3.0/GF/Canon/log.txt b/src-3.0/GF/Canon/log.txt deleted file mode 100644 index 44dba3954..000000000 --- a/src-3.0/GF/Canon/log.txt +++ /dev/null @@ -1,20 +0,0 @@ -GFCC, 6/9/2006 - -66661 24 Par remaining to be sent to GFC -66662 0 not covered by mkTerm -66663 36 label not in numeric format in mkTerm -66664 2 label not found in symbol table -66665 36 projection from deeper than just arg var: NP.agr.n -66667 0 parameter value not found in symbol table -66668 1 variable in parameter argument - - - -66664 2 -66665 125 missing: (VP.s!vf).fin -66668 1 - - -66661/3 24 same lines: -66664 2 -66668 1 diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs deleted file mode 100644 index b33d11017..000000000 --- a/src-3.0/GF/Compile/CheckGrammar.hs +++ /dev/null @@ -1,1078 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.31 $ --- --- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 --- --- type checking also does the following modifications: --- --- - types of operations and local constants are inferred and put in place --- --- - both these types and linearization types are computed --- --- - tables are type-annotated ------------------------------------------------------------------------------ - -module GF.Compile.CheckGrammar ( - showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Refresh ---- - -import GF.Grammar.TypeCheck -import GF.Grammar.Values (cPredefAbs) --- - -import GF.Grammar.PrGrammar -import GF.Grammar.Lookup -import GF.Grammar.LookAbs -import GF.Grammar.Macros -import GF.Grammar.ReservedWords ---- -import GF.Grammar.PatternMatch -import GF.Grammar.AppPredefined -import GF.Grammar.Lockfield (isLockLabel) - -import GF.Data.Operations -import GF.Infra.CheckM - -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace --- - - -showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String) -showCheckModule mos m = do - (st,(_,msg)) <- checkStart $ checkModule mos m - return (st, unlines $ reverse msg) - --- | checking is performed in the dependency order of modules -checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] -checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of - - ModMod mo@(Module mt st fs me ops js) -> do - checkRestrictedInheritance ms (name, mo) - js' <- case mt of - MTAbstract -> mapMTree (checkAbsInfo gr name) js - - MTTransfer a b -> mapMTree (checkAbsInfo gr name) js - - MTResource -> mapMTree (checkResInfo gr name) js - - MTConcrete a -> do - checkErr $ topoSortOpers $ allOperDependencies name js - ModMod abs <- checkErr $ lookupModule gr a - js1 <- checkCompleteGrammar abs mo - mapMTree (checkCncInfo gr name (a,abs)) js1 - - MTInterface -> mapMTree (checkResInfo gr name) js - - MTInstance a -> do - ModMod abs <- checkErr $ lookupModule gr a - -- checkCompleteInstance abs mo -- this is done in Rebuild - mapMTree (checkResInfo gr name) js - - return $ (name, ModMod (Module mt st fs me ops js')) : ms - - _ -> return $ (name,mod) : ms - where - gr = MGrammar $ (name,mod):ms - --- check if restricted inheritance modules are still coherent --- i.e. that the defs of remaining names don't depend on omitted names ----checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () -checkRestrictedInheritance mos (name,mo) = do - let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] - -- the restr. modules themself, with restr. infos - mapM_ checkRem mrs - where - checkRem ((i,m),mi) = do - let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) - let incld c = Set.member c (Set.fromList incl) - let illegal c = Set.member c (Set.fromList excl) - let illegals = [(f,is) | - (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] - case illegals of - [] -> return () - cs -> fail $ "In inherited module" +++ prt i ++ - ", dependence of excluded constants:" ++++ - unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | - (f,is) <- cs] - allDeps = ---- transClosure $ Map.fromList $ - concatMap (allDependencies (const True)) - [jments m | (_,ModMod m) <- mos] - transClosure ds = ds ---- TODO: check in deeper modules - --- | check if a term is typable -justCheckLTerm :: SourceGrammar -> Term -> Err Term -justCheckLTerm src t = do - ((t',_),_) <- checkStart (inferLType src t) - return t' - -checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkAbsInfo st m (c,info) = do ----- checkReservedId c - case info of - AbsCat (Yes cont) _ -> mkCheck "category" $ - checkContext st cont ---- also cstrs - AbsFun (Yes typ0) md -> do - typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ checkTyp st typ - md' <- case md of - Yes d -> do - let d' = elimTables d - mkCheckWarn "definition of function" $ checkEquation st (m,c) d' - return $ Yes d' - _ -> return md - return $ (c,AbsFun (Yes typ) md') - _ -> return (c,info) - where - mkCheck cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c - ---- temporary solution when tc of defs is incomplete - mkCheckWarn cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) - compAbsTyp g t = case t of - Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod x a b -> do - a' <- compAbsTyp g a - b' <- compAbsTyp ((x,Vr x):g) b - return $ Prod x a' b' - Abs _ _ -> return t - _ -> composOp (compAbsTyp g) t - - elimTables e = case e of - S t a -> elimSel (elimTables t) (elimTables a) - T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] - _ -> composSafeOp elimTables e - elimPatt p = case p of - PR lps -> map snd lps - _ -> [p] - elimSel t a = case a of - R fs -> mkApp t (map (snd . snd) fs) - _ -> mkApp t [a] - -checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info) -checkCompleteGrammar abs cnc = do - let js = jments cnc - let fs = tree2list $ jments abs - foldM checkOne js fs - where - checkOne js i@(c,info) = case info of - AbsFun (Yes _) _ -> case lookupIdent c js of - Ok _ -> return js - _ -> do - checkWarn $ "WARNING: no linearization of" +++ prt c - return js - AbsCat (Yes _) _ -> case lookupIdent c js of - Ok (AnyInd _ _) -> return js - Ok (CncCat (Yes _) _ _) -> return js - Ok (CncCat _ mt mp) -> do - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Yes defLinType) mt mp) js - _ -> do - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Yes defLinType) nope nope) js - _ -> return js - --- | General Principle: only Yes-values are checked. --- A May-value has always been checked in its origin module. -checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) -checkResInfo gr mo (c,info) = do - checkReservedId c - case info of - ResOper pty pde -> chIn "operation" $ do - (pty', pde') <- case (pty,pde) of - (Yes ty, Yes de) -> do - ty' <- check ty typeType >>= comp . fst - (de',_) <- check de ty' - return (Yes ty', Yes de') - (_, Yes de) -> do - (de',ty') <- infer de - return (Yes ty', Yes de') - (_,Nope) -> do - checkWarn "No definition given to oper" - return (pty,pde) - _ -> return (pty, pde) --- other cases are uninteresting - return (c, ResOper pty' pde') - - ResOverload tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip check) tysts - let tysts2 = [(y,x) | (x,y) <- tysts'] - --- this can only be a partial guarantee, since matching - --- with value type is only possible if expected type is given - checkUniq $ - sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]] - return (c,ResOverload tysts2) - - ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ----- mapM ((mapM (computeLType gr . snd)) . snd) pcs - mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs - ts <- checkErr $ lookupParamValues gr mo c - return (c,ResParam (Yes (pcs, Just ts))) - - _ -> return (c,info) - where - infer = inferLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - comp = computeLType gr - - checkUniq xss = case xss of - x:y:xs - | x == y -> raise $ "ambiguous for argument list" +++ - unwords (map (prtType gr) x) - | otherwise -> checkUniq $ y:xs - _ -> return () - - -checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> - (Ident,Info) -> Check (Ident,Info) -checkCncInfo gr m (a,abs) (c,info) = do - checkReservedId c - case info of - - CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do - typ <- checkErr $ lookupFunTypeSrc gr a c - cat0 <- checkErr $ valCat typ - (cont,val) <- linTypeOfType gr m typ -- creates arg vars - (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars - checkPrintname gr mpr - cat <- return $ snd cat0 - return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) - -- cat for cf, typ for pe - - CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do - checkErr $ lookupCatContextSrc gr a c - typ' <- checkIfLinType gr typ - mdef' <- case mdef of - Yes def -> do - (def',_) <- checkLType gr def (mkFunType [typeStr] typ) - return $ Yes def' - _ -> return mdef - checkPrintname gr mpr - return (c,CncCat (Yes typ') mdef' mpr) - - _ -> checkResInfo gr m (c,info) - - where - env = gr - infer = inferLType gr - comp = computeLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - -checkIfParType :: SourceGrammar -> Type -> Check () -checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) - where - isParType ty = True ---- -{- case ty of - Cn typ -> case lookupConcrete st typ of - Ok (CncParType _ _ _) -> True - Ok (CncOper _ ty' _) -> isParType ty' - _ -> False - Q p t -> case lookupInPackage st (p,t) of - Ok (CncParType _ _ _) -> True - _ -> False - RecType r -> all (isParType . snd) r - _ -> False --} - -checkIfStrType :: SourceGrammar -> Type -> Check () -checkIfStrType st typ = case typ of - Table arg val -> do - checkIfParType st arg - checkIfStrType st val - _ | typ == typeStr -> return () - _ -> prtFail "not a string type" typ - - -checkIfLinType :: SourceGrammar -> Type -> Check Type -checkIfLinType st typ0 = do - typ <- computeLType st typ0 - case typ of - RecType r -> do - let (lins,ihs) = partition (isLinLabel .fst) r - --- checkErr $ checkUnique $ map fst r - mapM_ checkInh ihs - mapM_ checkLin lins - _ -> prtFail "a linearization type must be a record type instead of" typ - return typ - - where - checkInh (label,typ) = checkIfParType st typ - checkLin (label,typ) = return () ---- checkIfStrType st typ - - -computeLType :: SourceGrammar -> Type -> Check Type -computeLType gr t = do - g0 <- checkGetContext - let g = [(x, Vr x) | (x,_) <- g0] - checkInContext g $ comp t - where - comp ty = case ty of - - App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed - - Q m c | elem c [cPredef,cPredefAbs] -> return ty - Q m c | elem c [zIdent "Int"] -> - return $ linTypeInt - Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ---- - - Q m ident -> checkIn ("module" +++ prt m) $ do - ty' <- checkErr (lookupResDef gr m ident) - if ty' == ty then return ty else comp ty' --- is this necessary to test? - - Vr ident -> checkLookup ident -- never needed to compute! - - App f a -> do - f' <- comp f - a' <- comp a - case f' of - Abs x b -> checkInContext [(x,a')] $ comp b - _ -> return $ App f' a' - - Prod x a b -> do - a' <- comp a - b' <- checkInContext [(x,Vr x)] $ comp b - return $ Prod x a' b' - - Abs x b -> do - b' <- checkInContext [(x,Vr x)] $ comp b - return $ Abs x b' - - ExtR r s -> do - r' <- comp r - s' <- comp s - case (r',s') of - (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs - liftM RecType $ mapPairsM comp fs' - - _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty - - _ -> composOp comp ty - -checkPrintname :: SourceGrammar -> Perh Term -> Check () -checkPrintname st (Yes t) = checkLType st t typeStr >> return () -checkPrintname _ _ = return () - --- | for grammars obtained otherwise than by parsing ---- update!! -checkReservedId :: Ident -> Check () -checkReservedId x = let c = prt x in - if isResWord c - then checkWarn ("Warning: reserved word used as identifier:" +++ c) - else return () - --- to normalize records and record types -labelIndex :: Type -> Label -> Int -labelIndex ty lab = case ty of - RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts - _ -> error $ "label index" +++ prt ty - where - labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] - --- the underlying algorithms - -inferLType :: SourceGrammar -> Term -> Check (Term, Type) -inferLType gr trm = case trm of - - Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - Q m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , -{- - do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> prtFail "not overloaded" trm - , --} - prtFail "cannot infer type of constant" trm - ] - - QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - QC m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , - prtFail "cannot infer type of canonical constant" trm - ] - - Val ty i -> termWith trm $ return ty - - Vr ident -> termWith trm $ checkLookup ident - - Typed e t -> do - t' <- comp t - check e t' - return (e,t') - - App f a -> do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> do - (f',fty) <- infer f - fty' <- comp fty - case fty' of - Prod z arg val -> do - a' <- justCheck a arg - ty <- if isWildIdent z - then return val - else substituteLType [(z,a')] val - return (App f' a',ty) - _ -> raise ("function type expected for"+++ - prt f +++"instead of" +++ prtType env fty) - - S f x -> do - (f', fty) <- infer f - case fty of - Table arg val -> do - x'<- justCheck x arg - return (S f' x', val) - _ -> prtFail "table lintype expected for the table in" trm - - P t i -> do - (t',ty) <- infer t --- ?? - ty' <- comp ty ------ let tr2 = PI t' i (labelIndex ty' i) - let tr2 = P t' i - termWith tr2 $ checkErr $ case ty' of - RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ - lookup i ts - _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' - PI t i _ -> infer $ P t i - - R r -> do - let (ls,fs) = unzip r - fsts <- mapM inferM fs - let ts = [ty | (Just ty,_) <- fsts] - checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) - return $ (R (zip ls fsts), RecType (zip ls ts)) - - T (TTyped arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - check trm (Table arg val) - T (TComp arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - check trm (Table arg val) - T ti pts -> do -- tries to guess: good in oper type inference - let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] - case pts' of - [] -> prtFail "cannot infer table type of" trm ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - check trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map infer pts - return (trm, Table arg val) - - K s -> do - if elem ' ' s - then checkWarn ("WARNING: space in token \"" ++ s ++ - "\". Lexical analysis may fail.") - else return () - return (trm, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - C s1 s2 -> - check2 (flip justCheck typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 - Strs (Cn (IC "#conflict") : ts) -> do - trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) --- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) --- infer $ head ts - - Strs ts -> do - ts' <- mapM (\t -> justCheck t typeStr) ts - return (Strs ts', typeStrs) - - Alts (t,aa) -> do - t' <- justCheck t typeStr - aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck c typeStr - v' <- justCheck v typeStrs - return (c',v')) - return (Alts (t',aa'), typeStr) - - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM (flip justCheck typeType) ts - return (RecType (zip ls ts'), typeType) - - ExtR r s -> do - (r',rT) <- infer r - rT' <- comp rT - (s',sT) <- infer s - sT' <- comp sT - - let trm' = ExtR r' s' - ---- trm' <- checkErr $ plusRecord r' s' - case (rT', sT') of - (RecType rs, RecType ss) -> do - rt <- checkErr $ plusRecType rT' sT' - check trm' rt ---- return (trm', rt) - _ | rT' == typeType && sT' == typeType -> return (trm', typeType) - _ -> prtFail "records or record types expected in" trm - - Sort _ -> - termWith trm $ return typeType - - Prod x a b -> do - a' <- justCheck a typeType - b' <- checkInContext [(x,a')] $ justCheck b typeType - return (Prod x a' b', typeType) - - Table p t -> do - p' <- justCheck p typeType --- check p partype! - t' <- justCheck t typeType - return $ (Table p' t', typeType) - - FV vs -> do - (_,ty) <- checks $ map infer vs ---- checkIfComplexVariantType trm ty - check trm ty - - _ -> prtFail "cannot infer lintype of" trm - - where - env = gr - infer = inferLType env - comp = computeLType env - - check = checkLType env - - isPredef m = elem m [cPredef,cPredefAbs] - - justCheck ty te = check ty te >>= return . fst - - -- for record fields, which may be typed - inferM (mty, t) = do - (t', ty') <- case mty of - Just ty -> check ty t - _ -> infer t - return (Just ty',t') - - inferCase mty (patt,term) = do - arg <- maybe (inferPatt patt) return mty - cont <- pattContext env arg patt - i <- checkUpdates cont - (_,val) <- infer term - checkResets i - return (arg,val) - isConstPatt p = case p of - PC _ ps -> True --- all isConstPatt ps - PP _ _ ps -> True --- all isConstPatt ps - PR ps -> all (isConstPatt . snd) ps - PT _ p -> isConstPatt p - PString _ -> True - PInt _ -> True - PFloat _ -> True - PChar -> True - PSeq p q -> isConstPatt p && isConstPatt q - PAlt p q -> isConstPatt p && isConstPatt q - PRep p -> isConstPatt p - PNeg p -> isConstPatt p - PAs _ p -> isConstPatt p - _ -> False - - inferPatt p = case p of - PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc - PAs _ p -> inferPatt p - PNeg p -> inferPatt p - PAlt p q -> checks [inferPatt p, inferPatt q] - PSeq _ _ -> return $ typeStr - PChar -> return $ typeStr - PRep _ -> return $ typeStr - _ -> infer (patt2term p) >>= return . snd - - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload env@gr mt t = case appForm t of - (f@(Q m c), ts) -> case lookupOverload gr m c of - Ok typs -> do - ttys <- mapM infer ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - _ -> return Nothing - where - infer = inferLType env - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - - case [vf | vf@(v,f) <- vfs, matchVal mt v] of - [(val,fun)] -> return (mkApp fun tts, val) - [] -> raise $ "no overload instance of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ - unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ - maybe [] (("with value type" +++) . prtType env) mt - - ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" - ---- ++++ unlines (map (show . fst) typs) ---- - - vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of - [(val,fun)] -> do - checkWarn $ "WARNING: overloading of" +++ prt f +++ - "resolved by excluding partial applications:" ++++ - unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - return (mkApp fun tts, val) - - _ -> raise $ "ambiguous overloading of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ - unlines [prtType env ty | (ty,_) <- vfs'] - - matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where - unlocked = case v of - RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs] - _ -> [] - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [(mkFunType rest val, t) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - pre == tys - ] - - noProd ty = case ty of - Prod _ _ _ -> False - _ -> True - -checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) -checkLType env trm typ0 = do - - typ <- comp typ0 - - case trm of - - Abs x c -> do - case typ of - Prod z a b -> do - checkUpdate (x,a) - (c',b') <- if isWildIdent z - then check c b - else do - b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b - check c b' - checkReset - return $ (Abs x c', Prod x a b') - _ -> raise $ "product expected instead of" +++ prtType env typ - - App f a -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - Q _ _ -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - T _ [] -> - prtFail "found empty table in type" typ - T _ cs -> case typ of - Table arg val -> do - case allParamValues env arg of - Ok vs -> do - let ps0 = map fst cs - ps <- checkErr $ testOvershadow ps0 vs - if null ps - then return () - else checkWarn $ "WARNING: patterns never reached:" +++ - concat (intersperse ", " (map prt ps)) - - _ -> return () -- happens with variable types - cs' <- mapM (checkCase arg val) cs - return (T (TTyped arg) cs', typ) - _ -> raise $ "table type expected for table instead of" +++ prtType env typ - - R r -> case typ of --- why needed? because inference may be too difficult - RecType rr -> do - let (ls,_) = unzip rr -- labels of expected type - fsts <- mapM (checkM r) rr -- check that they are found in the record - return $ (R fsts, typ) -- normalize record - - _ -> prtFail "record type expected in type checking instead of" typ - - ExtR r s -> case typ of - _ | typ == typeType -> do - trm' <- comp trm - case trm' of - RecType _ -> termWith trm $ return typeType - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType - -- ext t = t ** ... - _ -> prtFail "invalid record type extension" trm - RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- infer r - return (r',ty,s) - , - do (s',ty) <- infer s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck r' rr0 - s2 <- justCheck s' rr2 - return $ (ExtR r2 s2, typ) - _ -> raise ("record type expected in extension of" +++ prt r +++ - "but found" +++ prt ty) - - ExtR ty ex -> do - r' <- justCheck r ty - s' <- justCheck s ex - return $ (ExtR r' s', typ) --- is this all? - - _ -> prtFail "record extension not meaningful for" typ - - FV vs -> do - ttys <- mapM (flip check typ) vs ---- checkIfComplexVariantType trm typ - return (FV (map fst ttys), typ) --- typ' ? - - S tab arg -> checks [ do - (tab',ty) <- infer tab - ty' <- comp ty - case ty' of - Table p t -> do - (arg',val) <- check arg p - checkEq typ t trm - return (S tab' arg', t) - _ -> raise $ "table type expected for applied table instead of" +++ - prtType env ty' - , do - (arg',ty) <- infer arg - ty' <- comp ty - (tab',_) <- check tab (Table ty' typ) - return (S tab' arg', typ) - ] - Let (x,(mty,def)) body -> case mty of - Just ty -> do - (def',ty') <- check def ty - checkUpdate (x,ty') - body' <- justCheck body typ - checkReset - return (Let (x,(Just ty',def')) body', typ) - _ -> do - (def',ty) <- infer def -- tries to infer type of local constant - check (Let (x,(Just ty,def')) body) typ - - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - where - cnc = env - infer = inferLType env - comp = computeLType env - - check = checkLType env - - justCheck ty te = check ty te >>= return . fst - - checkEq = checkEqLType env - - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr - - checkM rms (l,ty) = case lookup l rms of - Just (Just ty0,t) -> do - checkEq ty ty0 t - (t',ty') <- check t ty - return (l,(Just ty',t')) - Just (_,t) -> do - (t',ty') <- check t ty - return (l,(Just ty',t')) - _ -> prtFail "cannot find value for label" l - - checkCase arg val (p,t) = do - cont <- pattContext env arg p - i <- checkUpdates cont - t' <- justCheck t val - checkResets i - return (p,t') - -pattContext :: LTEnv -> Type -> Patt -> Check Context -pattContext env typ p = case p of - PV x | not (isWildIdent x) -> return [(x,typ)] - PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- checkErr $ lookupResType cnc q c - (cont,v) <- checkErr $ typeFormCnc t - checkCond ("wrong number of arguments for constructor in" +++ prt p) - (length cont == length ps) - checkEqLType env typ v (patt2term p) - mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat - PR r -> do - typ' <- computeLType env typ - case typ' of - RecType t -> do - let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] - ----- checkWarn $ prt p ++++ show pts ----- debug - mapM (uncurry (pattContext env)) pts >>= return . concat - _ -> prtFail "record type expected for pattern instead of" typ' - PT t p' -> do - checkEqLType env typ t (patt2term p') - pattContext env typ p' - - PAs x p -> do - g <- pattContext env typ p - return $ (x,typ):g - - PAlt p' q -> do - g1 <- pattContext env typ p' - g2 <- pattContext env typ q - let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] - checkCond - ("incompatible bindings of" +++ - unwords (nub (map (prt . fst) pts))+++ - "in pattern alterantives" +++ prt p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env typ p - g2 <- pattContext env typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - cnc = env - noBind typ p' = do - co <- pattContext env typ p' - if not (null co) - then checkWarn ("no variable bound inside pattern" +++ prt p) - >> return [] - else return [] - --- auxiliaries - -type LTEnv = SourceGrammar - -termWith :: Term -> Check Type -> Check (Term, Type) -termWith t ct = do - ty <- ct - return (t,ty) - --- | light-weight substitution for dep. types -substituteLType :: Context -> Type -> Check Type -substituteLType g t = case t of - Vr x -> return $ maybe t id $ lookup x g - _ -> composOp (substituteLType g) t - --- | compositional check\/infer of binary operations -check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> - Term -> Term -> Type -> Check (Term,Type) -check2 chk con a b t = do - a' <- chk a - b' <- chk b - return (con a' b', t) - -checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type -checkEqLType env t u trm = do - (b,t',u',s) <- checkIfEqLType env t u trm - case b of - True -> return t' - False -> raise $ s +++ "type of" +++ prt trm +++ - ": expected:" +++ prtType env t ++++ - "inferred:" +++ prtType env u - -checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType env t u trm = do - t' <- comp t - u' <- comp u - case t' == u' || alpha [] t' u' of - True -> return (True,t',u',[]) - -- forgive missing lock fields by only generating a warning. - --- better: use a flag to forgive? (AR 31/1/2006) - _ -> case missingLock [] t' u' of - Ok lo -> do - checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) - return (True,t',u',[]) - Bad s -> return (False,t',u',s) - - where - - -- t is a subtype of u - --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of - - -- error (the empty type!) is subtype of any other type - (_,Q (IC "Predef") (IC "Error")) -> True - - -- contravariance - (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d - - -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> alpha g a b && l == k) ts) rs - (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' - (ExtR r s, t) -> alpha g r t || alpha g s t - - -- the following say that Ints n is a subset of Int and of Ints m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - Q (IC "Predef") (IC "Int")) -> True ---- check size! - - (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 - App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True - - ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - || m == n --- for Predef - (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - - (Table a b, Table c d) -> alpha g a c && alpha g b d - (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g - _ -> t == u - --- the following should be one-way coercions only. AR 4/1/2001 - || elem t sTypes && elem u sTypes - || (t == typeType && u == typePType) - || (u == typeType && t == typePType) - - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, - not (any (\ (k,b) -> alpha g a b && l == k) ts)] - (locks,others) = partition isLockLabel ls - in case others of - _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) - _ -> return locks - -- contravariance - (Prod x a b, Prod y c d) -> do - ls1 <- missingLock g c a - ls2 <- missingLock g b d - return $ ls1 ++ ls2 - - _ -> Bad "" - - sTypes = [typeStr, typeTok, typeString] - comp = computeLType env - --- printing a type with a lock field lock_C as C -prtType :: LTEnv -> Type -> String -prtType env ty = case ty of - RecType fs -> case filter isLockLabel $ map fst fs of - [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty - _ -> prtt ty - Prod x a b -> prtType env a +++ "->" +++ prtType env b - _ -> prtt ty - where - prtt t = prt t - ---- use computeLType gr to check if really equal to the cat with lock - - --- | linearization types and defaults -linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) -linTypeOfType cnc m typ = do - (cont,cat) <- checkErr $ typeSkeleton typ - val <- lookLin cat - args <- mapM mkLinArg (zip [0..] cont) - return (args, val) - where - mkLinArg (i,(n,mc@(m,cat))) = do - val <- lookLin mc - let vars = mkRecType varLabel $ replicate n typeStr - symb = argIdent n cat i - rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ - plusRecType vars val - return (symb,rec) - lookLin (_,c) = checks [ --- rather: update with defLinType ? - checkErr (lookupLincat cnc m c) >>= computeLType cnc - ,return defLinType - ] - --- | dependency check, detecting circularities and returning topo-sorted list - -allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] -allOperDependencies m = allDependencies (==m) - -allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] -allDependencies ism b = - [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] - where - opersIn t = case t of - Q n c | ism n -> [c] - QC n c | ism n -> [c] - _ -> collectOp opersIn t - opty (Yes ty) = opersIn ty - opty _ = [] - pts i = case i of - ResOper pty pt -> [pty,pt] - ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont] - CncCat pty _ _ -> [pty] - CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) - AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual - AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co] - _ -> [] - -topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] -topoSortOpers st = do - let eops = topoTest st - either - return - (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) - eops diff --git a/src-3.0/GF/Compile/Compile.hs b/src-3.0/GF/Compile/Compile.hs deleted file mode 100644 index 422df0fd5..000000000 --- a/src-3.0/GF/Compile/Compile.hs +++ /dev/null @@ -1,401 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compile --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/05 20:02:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.45 $ --- --- The top-level compilation chain from source file to gfc\/gfr. ------------------------------------------------------------------------------ - -module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne, - CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts, - getGFEFiles) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.CompactPrint -import GF.Grammar.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Infra.ReadFiles -import GF.Compile.ShellState -import GF.Compile.MkResource ----- import MkUnion - --- the main compiler passes -import GF.Compile.GetGrammar -import GF.Compile.Extend -import GF.Compile.Rebuild -import GF.Compile.Rename -import GF.Grammar.Refresh -import GF.Compile.CheckGrammar -import GF.Compile.Optimize -import GF.Compile.Evaluate -import GF.Compile.GrammarToCanon ---import GF.Devel.GrammarToGFCC ----- -import GF.Devel.OptimizeGF (subexpModule,unsubexpModule) -import GF.Canon.Share -import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) -import GF.UseGrammar.Linear (unoptimizeCanonMod) ---- - -import qualified GF.Canon.CanonToGrammar as CG - -import qualified GF.Canon.GFC as GFC -import qualified GF.Canon.MkGFC as MkGFC -import GF.Canon.GetGFC - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Text.UTF8 ---- -import GF.System.Arch - -import Control.Monad -import System.Directory -import System.FilePath - --- | in batch mode: write code in a file -batchCompile f = liftM fst $ compileModule defOpts emptyShellState f - where - defOpts = options [emitCode] -batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f - where - defOpts = options [emitCode, optimizeCanon] - -batchCompileOld f = compileOld defOpts f - where - defOpts = options [emitCode] - --- | compile with one module as starting point --- command-line options override options (marked by --#) in the file --- As for path: if it is read from file, the file path is prepended to each name. --- If from command line, it is used as it is. -compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv ----- IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))])) - -compileModule opts st0 file | - oElem showOld opts || - elem suff [".cf",".ebnf",".gfm"] = do - let putp = putPointE opts - let putpp = putPointEsil opts - let path = [] ---- - grammar1 <- case suff of - ".cf" -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file - ".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file - ".gfm" -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file - _ -> putp ("- parsing old gf" +++ file) $ getOldGrammar opts file - let mods = modules grammar1 - let env = compileEnvShSt st0 [] - foldM (comp putpp path) env mods - where - suff = takeExtensions file - comp putpp path env sm0 = do - (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm - ft <- getReadTimes file --- - extendCompileEnvInt env (k',sm,cm) eenv' ft - -compileModule opts1 st0 file = do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (ps0 ++ map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) - ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let st = st0 --- if useFileOpt then emptyShellState else st0 - let rfs = [(m,t) | (m,(_,t)) <- readFiles st] - let file' = if useFileOpt then takeFileName file else file -- to find file itself - files <- getAllFiles opts ps rfs file' - ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- - let names = map justModuleName files - ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- - let env0 = compileEnvShSt st names - (e,mm) <- foldIOE (compileOne opts) env0 files - maybe (return ()) putStrLnE mm - return e - -getReadTimes file = do - t <- ioeIO getNowTime - let m = justModuleName file - return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)] - -compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv -compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where - cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i] - sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i] - notInc i = notElem (prt i) $ map dropExtension fs - notIns i = notElem (prt i) $ map dropExtension fs - fts = readFiles st - eenv = evalEnv st - -pathListOpts :: Options -> FileName -> IO [InitPath] -pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList - -reverseModules (MGrammar ms) = MGrammar $ reverse ms - -keepResModules :: Options -> SourceGrammar -> SourceGrammar -keepResModules opts gr = - if oElem retainOpers opts - then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m] - else emptyMGrammar - - --- | the environment -type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv) - -emptyCompileEnv :: TimedCompileEnv -emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[]) - -extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft = - return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later - -extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm) - -extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft = - return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts) - -type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))]) - -compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv -compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do - - let putp = putPointE opts - let putpp = putPointEsil opts - let putpOpt v m act - | oElem beVerbose opts = putp v act - | oElem beSilent opts = putpp v act - | otherwise = ioeIO (putStrFlush m) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = modules srcgr - - case gf of - -- for multilingual canonical gf, just read the file and update environment - ".gfcm" -> do - cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file - ft <- getReadTimes file - extendCompileEnvCanon env cgr eenv ft - - -- for canonical gf, read the file and update environment, also source env - ".gfc" -> do - cm <- putp ("+ reading" +++ file) $ getCanonModule file - let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 - sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm - ft <- getReadTimes file - extendCompileEnv env (sm, cm) eenv ft - - -- for compiled resource, parse and organize, then update environment - ".gfr" -> do - sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 ----- experiment with not optimizing gfr ----- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1 - let gfc = gfcFile name - cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc - ft <- getReadTimes file - extendCompileEnv env (sm,cm) eenv ft - - -- for gf source, do full compilation - - _ -> do - - --- hack fix to a bug in ReadFiles with reused concrete - - let modu = dropExtension file - b1 <- ioeIO $ doesFileExist file - b2 <- ioeIO $ doesFileExist $ gfrFile modu - if not b1 - then if b2 - then compileOne opts env $ gfrFile $ modu - else compileOne opts env $ gfcFile $ modu - else do - - sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm - ft <- getReadTimes file - - sm':_ <- case snd sm of ----- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm - _ -> return [sm] - - extendCompileEnvInt env (k',sm',cm) eenv' ft - --- | dispatch reused resource at early stage -makeSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule,EEnv) -makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of - - ModMod m -> case mtype m of - MTReuse c -> do - sm <- ioeErr $ makeReuse gr i (extend m) c - let mo2 = (i, ModMod sm) - mos = modules gr - --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 - return $ (k,mo2,eenv) -{- ---- obsolete - MTUnion ty imps -> do - mo' <- ioeErr $ makeUnion gr i ty imps - compileSourceModule opts env mo' --} - - _ -> compileSourceModule opts env mo - _ -> compileSourceModule opts env mo - where - putp = putPointE opts - -compileSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule,EEnv) -compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do - - let putp = putPointE opts - putpp = putPointEsil opts - mos = modules gr - - if (oElem showOld opts && oElem emitCode opts) - then do - let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file out - else return () - - mo1 <- ioeErr $ rebuildModule mos mo - - mo1b <- ioeErr $ extendModule mos mo1 - - case mo1b of - (_,ModMod n) | not (isCompleteModule n) -> do - return (k,mo1b,eenv) -- refresh would fail, since not renamed - _ -> do - mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - - (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 - if null warnings then return () else putp warnings $ return () - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - - (mo4,eenv') <- - ---- if oElem "check_only" opts - putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r - return (k',mo4,eenv') - where - ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug - prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] - -generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule -generateModuleCode opts path minfo@(name,info) = do - ---- DEPREC ---- if oElem (iOpt "gfcc") opts ---- then ioeIO $ putStrLn $ prGrammar2gfcc minfo ---- else return () - - let pname = path prt name - minfo0 <- ioeErr $ redModInfo minfo - let oopts = addOptions opts (iOpts (flagsModule minfo)) - optims = maybe "all_subs" id $ getOptVal oopts useOptimizer - optim = takeWhile (/='_') optims - subs = drop 1 (dropWhile (/='_') optims) == "subs" - minfo1 <- return $ - case optim of - "parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing - "values" -> shareModule valOpt minfo0 -- tables as courses-of-values - "share" -> shareModule shareOpt minfo0 -- sharing of branches - "all" -> shareModule allOpt minfo0 -- first parametrize then values - "none" -> minfo0 -- no optimization - _ -> shareModule shareOpt minfo0 -- sharing; default - - -- do common subexpression elimination if required by flag "subs" - minfo' <- - if subs - then ioeErr $ elimSubtermsMod minfo1 - else return minfo1 - - -- for resource, also emit gfr. - --- Also for incomplete, to create timestamped gfc/gfr files - case info of - ModMod m | emitsGFR m && emit && nomulti -> do - let rminfo = if isCompilable info - then subexpModule minfo - else (name, ModMod emptyModule) - let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out - _ -> return () - let encode = case getOptVal opts uniCoding of - Just "utf8" -> encodeUTF8 - _ -> id - (file,out) <- do - code <- return $ MkGFC.prCanonModInfo minfo' - return (gfcFile pname, encode code) - if emit && nomulti ---- && isCompilable info - then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out - else putpp ("no need to save module" +++ prt name) $ return () - return minfo' - where - putp = putPointE opts - putpp = putPointEsil opts - - emitsGFR m = isModRes m ---- && isCompilable info - ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete) - isCompilable mi = case mi of - ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete - _ -> True - nomulti = not $ oElem makeMulti opts - emit = oElem emitCode opts && not (oElem notEmitCode opts) - --- for old GF: sort into modules, write files, compile as usual - -compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar -compileOld opts file = do - let putp = putPointE opts - grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file - files <- mapM writeNewGF $ modules grammar1 - ((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files - return grammar - -writeNewGF :: SourceModule -> IOE FilePath -writeNewGF m@(i,_) = do - let file = gfFile $ prt i - ioeIO $ writeFile file $ prGrammar (MGrammar [m]) - ioeIO $ putStrLn $ "wrote file" +++ file - return file - ---- this function duplicates a lot of code from compileModule. ---- It does not really belong here either. --- It selects those .gfe files that a grammar depends on and that --- are younger than corresponding gf - -getGFEFiles :: Options -> FilePath -> IO [FilePath] -getGFEFiles opts1 file = useIOE [] $ do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let file' = if useFileOpt then takeFileName file else file -- to find file itself - files <- getAllFiles opts ps [] file' - efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files] - es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf - return $ filter ((=='e') . last) es diff --git a/src-3.0/GF/Compile/Evaluate.hs b/src-3.0/GF/Compile/Evaluate.hs deleted file mode 100644 index a574fef40..000000000 --- a/src-3.0/GF/Compile/Evaluate.hs +++ /dev/null @@ -1,477 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Evaluate --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Data.Str -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Infra.Option -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel) ---- - -import GF.Grammar.AppPredefined - -import qualified Data.Map as Map - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) -import Debug.Trace - - -data EEnv = EEnv { - computd :: Map.Map (Ident,Ident) FTerm, - temp :: Int - } - -emptyEEnv = EEnv Map.empty 0 - -lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm) -lookupComputed mc = do - env <- readSTM - return $ Map.lookup mc $ computd env - -updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv () -updateComputed mc t = - updateSTM (\e -> e{computd = Map.insert mc t (computd e)}) - -getTemp :: STM EEnv Ident -getTemp = do - env <- readSTM - updateSTM (\e -> e{temp = temp e + 1}) - return $ identC ("#" ++ show (temp env)) - -data FTerm = - FTC Term - | FTF (Term -> FTerm) - -prFTerm :: Integer -> FTerm -> String -prFTerm i t = case t of - FTC t -> prt t - FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i)) - -term2fterm t = case t of - Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b)) - _ -> FTC t - -traceFTerm c ft = ft ---- -----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft - -fterm2term :: FTerm -> STM EEnv Term -fterm2term t = case t of - FTC t -> return t - FTF f -> do - x <- getTemp - b <- fterm2term $ f (Vr x) - return $ Abs x b - -subst g t = case t of - Vr x -> maybe t id $ lookup x g - _ -> composSafeOp (subst g) t - - -appFTerm :: FTerm -> [Term] -> FTerm -appFTerm ft ts = case (ft,ts) of - (FTF f, x:xs) -> appFTerm (f x) xs - (FTC c, _:_) -> FTC $ foldl App c ts - _ -> ft - -apps :: Term -> (Term,[Term]) -apps t = case t of - App f a -> (f',xs ++ [a]) where (f',xs) = apps f - _ -> (t,[]) - -appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env - -evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info) -evalConcrete gr mo = mapMTree evaldef mo where - - evaldef (f,info) = case info of - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $ - do - pde' <- case pde of - Yes de -> do - liftM yes $ pEval ty de - _ -> return pde - --- ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed - - _ -> return (f,info) - - pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do - let - vars = map fst context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm3 <- recordExpand val trm1 >>= comp subst >>= recomp subst - return $ mkAbs vars trm3 - - ---- temporary hack to ascertain full evaluation, because of bug in comp - recomp g t = if notReady t then comp g t else return t - notReady = not . null . redexes - redexes t = case t of - Q _ _ -> return [()] - _ -> collectOp redexes t - - recordExpand typ trm = case unComputed typ of - RecType tys -> case trm of - FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] - _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] - _ -> return trm - - comp g t = case t of - - Q (IC "Predef") _ -> return t ----trace ("\nPredef:\n" ++ prt t) $ return t - - Q p c -> do - md <- lookupComputed (p,c) - case md of - Nothing -> do - d <- lookRes (p,c) - updateComputed (p,c) $ traceFTerm c $ term2fterm d - return d - Just d -> fterm2term d >>= comp g - App f a -> case apps t of -{- ---- - (h@(QC p c),xs) -> do - xs' <- mapM (comp g) xs - case lookupValueIndex gr ty t of - Ok v -> return v - _ -> return t --} - (h@(Q p c),xs) | p == IC "Predef" -> do - xs' <- mapM (comp g) xs - (t',b) <- stmErr $ appPredefined (foldl App h xs') - if b then return t' else comp g t' - (h@(Q p c),xs) -> do - xs' <- mapM (comp g) xs - md <- lookupComputed (p,c) - case md of - Just ft -> do - t <- fterm2term $ appFTerm ft xs' - comp g t - Nothing -> do - d <- lookRes (p,c) - let ft = traceFTerm c $ term2fterm d - updateComputed (p,c) ft - t' <- fterm2term $ appFTerm ft xs' - comp g t' - _ -> do - f' <- comp g f - a' <- comp g a - case (f',a') of - (Abs x b,_) -> comp (ext x a' g) b - (QC _ _,_) -> returnC $ App f' a' - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - - (Alias _ _ d, _) -> comp g (App d a') - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e - - _ -> do - (t',b) <- stmErr $ appPredefined (App f' a') - if b then return t' else comp g t' - - - Vr x -> do - t' <- maybe (prtRaise ( - "context" +++ show g +++ ": no value given to variable") x) return $ lookup x g - case t' of - _ | t == t' -> return t - _ -> comp g t' - - Abs x b -> do - b' <- comp (ext x (Vr x) g) b - return $ Abs x b' - - Let (x,(_,a)) b -> do - a' <- comp g a - comp (ext x a' g) b - - Prod x a b -> do - a' <- comp g a - b' <- comp (ext x (Vr x) g) b - return $ Prod x a' b' - - P t l | isLockLabel l -> return $ R [] - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field - - - P t l -> do - t' <- comp g t - case t' of - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants - R r -> maybe - (prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $ - lookup l r - - ExtR a (R b) -> case lookup l b of ----comp g (P (R b) l) of - Just (_,v) -> comp g v - _ -> comp g (P a l) - ExtR (R a) b -> case lookup l a of ----comp g (P (R b) l) of - Just (_,v) -> comp g v - _ -> comp g (P b l) - - S (T i cs) e -> prawitz g i (flip P l) cs e - - _ -> returnC $ P t' l - - S t@(T _ cc) v -> do - v' <- comp g v - case v' of - FV vs -> do - ts' <- mapM (comp g . S t) vs - return $ variants ts' - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - - S t v -> do - t' <- comp g t - v' <- comp g v - case t' of - T _ [(PV IW,c)] -> comp g c --- an optimization - T _ [(PT _ (PV IW),c)] -> comp g c - - T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization - T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c - - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - V ptyp ts -> do - vs <- stmErr $ allParamValues gr ptyp - ps <- stmErr $ mapM term2patt vs - let cc = zip ps ts - case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t - _ -> return $ S t' v' -- if v' is not canonical - - T _ cc -> case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t - _ -> return $ S t' v' -- if v' is not canonical - - Alias _ _ d -> comp g (S d v') - - S (T i cs) e -> prawitz g i (flip S v') cs e - - _ -> returnC $ S t' v' - - -- normalize away empty tokens - K "" -> return Empty - - -- glue if you can - Glue x0 y0 -> do - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (Alias _ _ d, y) -> comp g $ Glue d y - (x, Alias _ _ d) -> comp g $ Glue x d - - (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e - (s, S (T i cs) e) -> prawitz g i (Glue s) cs e - (_,Empty) -> return x - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) - (_, Alts (d,vs)) -> do ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) - (Alts _, ka) -> checks [do - y' <- stmErr $ strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (FV ks,_) -> do - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - _ -> do - mapM_ checkNoArgVars [x,y] - r <- composOp (comp g) t - returnC r - - Alts _ -> do - r <- composOp (comp g) t - returnC r - - -- remove empty - C a b -> do - a' <- comp g a - b' <- comp g b - case (a',b') of - (Alts _, K a) -> checks [do - as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] - , - return $ C a' b' - ] - (Empty,_) -> returnC b' - (_,Empty) -> returnC a' - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants - - -- merge record extensions if you can - ExtR r s -> do - r' <- comp g r - s' <- comp g s - case (r',s') of - (Alias _ _ d, _) -> comp g $ ExtR d s' - (_, Alias _ _ d) -> comp g $ Glue r' d - - (R rs, R ss) -> stmErr $ plusRecord r' s' - (RecType rs, RecType ss) -> stmErr $ plusRecType r' s' - - (_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss] - - _ -> return $ ExtR r' s' - - -- case-expand tables - -- if already expanded, don't expand again - T i@(TComp _) cs -> do - -- if there are no variables, don't even go inside - cs' <- {-if (null g) then return cs else-} mapPairsM (comp g) cs - return $ T i cs' - - --- this means some extra work; should implement TSh directly - TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] - - T i cs -> do - pty0 <- stmErr $ getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs -> do - - cs' <- mapM (compBranchOpt g) cs - sts <- stmErr $ mapM (matchPattern cs') vs - ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts - ps <- stmErr $ mapM term2patt vs - let ps' = ps --- PT ptyp (head ps) : tail ps - return $ --- V ptyp ts -- to save space, just course of values - T (TComp ptyp) (zip ps' ts) - _ -> do - cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - - -- otherwise go ahead - _ -> composOp (comp g) t >>= returnC - - lookRes (p,c) = case lookupResDefKind gr p c of - Ok (t,_) | noExpand p -> return t - Ok (t,0) -> comp [] t - Ok (t,_) -> return t - Bad s -> raise s - - noExpand p = errVal False $ do - mo <- lookupModMod gr p - return $ case getOptVal (iOpts (flags mo)) useOptimizer of - Just "noexpand" -> True - _ -> False - - prtRaise s t = raise (s +++ prt t) - - ext x a g = (x,a):g - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - ts -> FV ts - - isCan v = case v of - Con _ -> True - QC _ _ -> True - App f a -> isCan f && isCan a - R rs -> all (isCan . snd . snd) rs - _ -> False - - compBranch g (p,v) = do - let g' = contP p ++ g - v' <- comp g' v - return (p,v') - - compBranchOpt g c@(p,v) = case contP p of - [] -> return c - _ -> compBranch g c ----- _ -> err (const (return c)) return $ compBranch g c - - contP p = case p of - PV x -> [(x,Vr x)] - PC _ ps -> concatMap contP ps - PP _ _ ps -> concatMap contP ps - PT _ p -> contP p - PR rs -> concatMap (contP . snd) rs - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - --- | argument variables cannot be glued -checkNoArgVars :: Term -> STM EEnv Term -checkNoArgVars t = case t of - Vr (IA _) -> raise $ glueErrorMsg $ prt t - Vr (IAV _) -> raise $ glueErrorMsg $ prt t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." - -stmErr :: Err a -> STM s a -stmErr e = stm (\s -> do - v <- e - return (v,s) - ) - -evalIn :: String -> STM s a -> STM s a -evalIn msg st = stm $ \s -> case appSTM st s of - Bad e -> Bad $ msg ++++ e - Ok vs -> Ok vs diff --git a/src-3.0/GF/Compile/Flatten.hs b/src-3.0/GF/Compile/Flatten.hs deleted file mode 100644 index 1168ca6da..000000000 --- a/src-3.0/GF/Compile/Flatten.hs +++ /dev/null @@ -1,92 +0,0 @@ -module Flatten where - -import Data.List --- import GF.Data.Operations - --- (AR 15/3/2006) --- --- A method for flattening grammars: create many flat rules instead of --- a few deep ones. This is generally better for parsins. --- The rules are obtained as follows: --- 1. write a config file tellinq which constants are variables: format 'c : C' --- 2. generate a list of trees with their types: format 't : T' --- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin --- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as --- found in the config file. --- 4. You can go on and produce def or transfer rules similar to the lin rules --- except for the keyword. --- --- So far this module is used outside gf. You can e.g. generate a list of --- trees by 'gt', write it in a file, and then in ghci call --- flattenGrammar - -type Ident = String --- -type Term = String --- -type Rule = String --- - -type Config = [(Ident,Ident)] - -flattenGrammar :: FilePath -> FilePath -> FilePath -> IO () -flattenGrammar conff tf out = do - conf <- readFile conff >>= return . lines - ts <- readFile tf >>= return . lines - writeFile out $ mkFlatten conf ts - -mkFlatten :: [String] -> [String] -> String -mkFlatten conff = unlines . concatMap getOne . zip [1..] where - getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y] - conf = getConfig conff - -mkRules :: Config -> Ident -> Term -> (Rule,Rule) -mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where - args = mkArgs conf ts - ty = concat [a ++ " -> " | a <- map snd args] ++ val - (ts,val) = let tt = lexTerm t in (init tt,last tt) ---- f = identV t - fun c a = unwords [" fun", c, ":",a,";"] - lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"] - -mkArgs :: Config -> [Ident] -> [(Ident,Ident)] -mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]] - -mkIdent :: Term -> Ident -mkIdent = map mkChar where - mkChar c = case c of - '(' -> '6' - ')' -> '9' - ' ' -> '_' - _ -> c - --- to get just the identifiers -lexTerm :: String -> [String] -lexTerm ss = case lex ss of - [([c],ws)] | isSpec c -> lexTerm ws - [(w@(_:_),ws)] -> w : lexTerm ws - _ -> [] - where - isSpec = flip elem "();:" - - -getConfig :: [String] -> Config -getConfig = map getOne . filter (not . null) where - getOne line = case lexTerm line of - v:c:_ -> (v,c) - -ex = putStrLn fs where - fs = - mkFlatten - ["man_N : N", - "sleep_V : V" - ] - ["PredVP (DefSg man_N) (UseV sleep_V) : Cl", - "PredVP (DefPl man_N) (UseV sleep_V) : Cl" - ] - -{- --- result of ex - - fun fu1 : N -> V -> Cl ; - lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ; - fun fu2 : N -> V -> Cl ; - lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ; --} diff --git a/src-3.0/GF/Compile/GetGrammar.hs b/src-3.0/GF/Compile/GetGrammar.hs deleted file mode 100644 index 294edbf9a..000000000 --- a/src-3.0/GF/Compile/GetGrammar.hs +++ /dev/null @@ -1,146 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- this module builds the internal GF grammar that is sent to the type checker ------------------------------------------------------------------------------ - -module GF.Compile.GetGrammar ( - getSourceModule, getSourceGrammar, - getOldGrammar, getCFGrammar, getEBNFGrammar - ) where - -import GF.Data.Operations -import qualified GF.Source.ErrM as E - -import GF.Infra.UseIO -import GF.Grammar.Grammar -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import qualified GF.Source.AbsGF as A -import GF.Source.SourceToGrammar ----- import Macros ----- import Rename -import GF.Text.UTF8 ---- -import GF.Infra.Option ---- import Custom -import GF.Source.ParGF -import qualified GF.Source.LexGF as L - -import GF.CF.CF (rules2CF) -import GF.CF.PPrCF -import GF.CF.CFtoGrammar -import GF.CF.EBNF - -import GF.Infra.ReadFiles ---- - -import Data.Char (toUpper) -import Data.List (nub) -import qualified Data.ByteString.Char8 as BS -import Control.Monad (foldM) -import System (system) -import System.FilePath - -getSourceModule :: Options -> FilePath -> IOE SourceModule -getSourceModule opts file0 = do - file <- case getOptVal opts usePreprocessor of - Just p -> do - let tmp = "_gf_preproc.tmp" - cmd = p +++ file0 ++ ">" ++ tmp - ioeIO $ system cmd - -- ioeIO $ putStrLn $ "preproc" +++ cmd - return tmp - _ -> return file0 - string0 <- readFileIOE file - let string = case getOptVal opts uniCoding of - Just "utf8" -> decodeUTF8 string0 - _ -> string0 - let tokens = myLexer (BS.pack string) - mo1 <- ioeErr $ pModDef tokens - ioeErr $ transModDef mo1 - -getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar -getSourceGrammar opts file = do - string <- readFileIOE file - let tokens = myLexer (BS.pack string) - gr1 <- ioeErr $ pGrammar tokens - ioeErr $ transGrammar gr1 - - --- for old GF format with includes - -getOldGrammar :: Options -> FilePath -> IOE SourceGrammar -getOldGrammar opts file = do - defs <- parseOldGrammarFiles file - let g = A.OldGr A.NoIncl defs - let name = takeFileName file - ioeErr $ transOldGrammar opts name g - -parseOldGrammarFiles :: FilePath -> IOE [A.TopDef] -parseOldGrammarFiles file = do - putStrLnE $ "reading grammar of old format" +++ file - (_, g) <- getImports "" ([],[]) file - return g -- now we can throw away includes - where - getImports oldInitPath (oldImps, oldG) f = do - (path,s) <- readFileLibraryIOE oldInitPath f - if not (elem path oldImps) - then do - (imps,g) <- parseOldGrammar path - foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps - else - return (oldImps, oldG) - -parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef]) -parseOldGrammar file = do - putStrLnE $ "reading old file" +++ file - s <- ioeIO $ readFileIf file - A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s - includes <- ioeErr $ transInclude incl - return (includes, topdefs) - ----- - --- | To resolve the new reserved words: --- change them by turning the final letter to upper case. ---- There is a risk of clash. -oldLexer :: String -> [L.Token] -oldLexer = map change . L.tokens . BS.pack where - change t = case t of - (L.PT p (L.TS s)) | elem s newReservedWords -> - (L.PT p (L.TV (init s ++ [toUpper (last s)]))) - _ -> t - -getCFGrammar :: Options -> FilePath -> IOE SourceGrammar -getCFGrammar opts file = do - let mo = takeWhile (/='.') file - s <- ioeIO $ readFileIf file - let files = case words (concat (take 1 (lines s))) of - "--":"include":fs -> fs - _ -> [] - ss <- ioeIO $ mapM readFileIf files - cfs <- ioeErr $ mapM (pCF mo) $ s:ss - defs <- return $ cf2grammar $ rules2CF $ concat cfs - let g = A.OldGr A.NoIncl defs ---- let ma = justModuleName file ---- let mc = 'C':ma --- ---- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts - ioeErr $ transOldGrammar opts file g - -getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar -getEBNFGrammar opts file = do - let mo = takeWhile (/='.') file - s <- ioeIO $ readFileIf file - defs <- ioeErr $ pEBNFasGrammar s - let g = A.OldGr A.NoIncl defs ---- let ma = justModuleName file ---- let mc = 'C':ma --- ---- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts - ioeErr $ transOldGrammar opts file g diff --git a/src-3.0/GF/Compile/GrammarToCanon.hs b/src-3.0/GF/Compile/GrammarToCanon.hs deleted file mode 100644 index 09c0d3d95..000000000 --- a/src-3.0/GF/Compile/GrammarToCanon.hs +++ /dev/null @@ -1,293 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToCanon --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.23 $ --- --- Code generator from optimized GF source code to GFC. ------------------------------------------------------------------------------ - -module GF.Compile.GrammarToCanon (showGFC, - redModInfo, redQIdent - ) where - -import GF.Data.Operations -import GF.Data.Zipper -import GF.Infra.Option -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Grammar.Macros -import qualified GF.Canon.AbsGFC as G -import qualified GF.Canon.GFC as C -import GF.Canon.MkGFC ----- import Alias -import qualified GF.Canon.PrintGFC as P - -import Control.Monad -import Data.List (nub,sortBy) - --- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003 - --- | This is the top-level function printing a gfc file -showGFC :: SourceGrammar -> String -showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar - --- | any grammar, first trying without dependent types --- abstract syntax without dependent types -redGrammar :: SourceGrammar -> Err C.CanonGrammar -redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where - active (_,m) = case typeOfModule m of - MTInterface -> False - _ -> True - -redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo) -redModInfo (c,info) = do - c' <- redIdent c - info' <- case info of - ModMod m -> do - let isIncompl = not $ isCompleteModule m - (e,os) <- if isIncompl then return ([],[]) else redExtOpen m ---- - flags <- mapM redFlag $ flags m - (a,mt0) <- case mtype m of - MTConcrete a -> do - a' <- redIdent a - return (a', MTConcrete a') - MTAbstract -> return (c',MTAbstract) --- c' not needed - MTResource -> return (c',MTResource) --- c' not needed - MTInterface -> return (c',MTResource) ---- not needed - MTInstance _ -> return (c',MTResource) --- c' not needed - MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed - - --- this generates empty GFC reosurce for interface and incomplete - let js = if isIncompl then emptyBinTree else jments m - mt = mt0 ---- if isIncompl then MTResource else mt0 - - defss <- mapM (redInfo a) $ tree2list $ js - let defs0 = concat defss - let lgh = length defs0 - defs <- return $ sorted2tree $ defs0 -- sorted, but reduced - let flags1 = if isIncompl then C.flagIncomplete : flags else flags - let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1 - return $ ModMod $ Module mt MSComplete flags' e os defs - return (c',info') - where - redExtOpen m = do - e' <- case extends m of - es -> mapM (liftM inheritAll . redIdent) es - os' <- mapM (\o -> case o of - OQualif q _ i -> liftM (OSimple q) (redIdent i) - _ -> prtBad "cannot translate unqualified open in" c) $ opens m - return (e',nub os') - om = oSimple . openedModule --- normalizing away qualif - -redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)] -redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do - c' <- redIdent c - case info of - AbsCat (Yes cont) pfs -> do - let fs = case pfs of - Yes ts -> [(m,c) | Q m c <- ts] - _ -> [] - returns c' $ C.AbsCat cont fs - AbsFun (Yes typ) pdf -> do - let df = case pdf of - Yes t -> t -- definition or "data" - _ -> Eqs [] -- primitive notion - returns c' $ C.AbsFun typ df - AbsTrans t -> - returns c' $ C.AbsTrans t - - ResParam (Yes (ps,_)) -> do - ps' <- mapM redParam ps - returns c' $ C.ResPar ps' - - CncCat pty ptr ppr -> case (pty,ptr,ppr) of - (Yes ty, Yes (Abs _ t), Yes pr) -> do - ty' <- redCType ty - trm' <- redCTerm t - pr' <- redCTerm pr - return [(c', C.CncCat ty' trm' pr')] - _ -> prtBad ("cannot reduce rule for") c - - CncFun mt ptr ppr -> case (mt,ptr,ppr) of - (Just (cat,_), Yes trm, Yes pr) -> do - cat' <- redIdent cat - (xx,body,_) <- termForm trm - xx' <- mapM redArgvar xx - body' <- errIn (prt body) $ redCTerm body ---- debug - pr' <- redCTerm pr - return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')] - _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug - - AnyInd s b -> do - b' <- redIdent b - returns c' $ C.AnyInd s b' - - _ -> return [] --- retain some operations - where - returns f i = return [(f,i)] - -redQIdent :: QIdent -> Err G.CIdent -redQIdent (m,c) = return $ G.CIQ m c - -redIdent :: Ident -> Err Ident -redIdent x - | isWildIdent x = return $ identC "h_" --- needed in declarations - | otherwise = return $ identC $ prt x --- - -redFlag :: Option -> Err G.Flag -redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x) -redFlag o = Bad $ "cannot reduce option" +++ prOpt o - -redDecl :: Decl -> Err G.Decl -redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a) - -redType :: Type -> Err G.Exp -redType = redTerm - -redTerm :: Type -> Err G.Exp -redTerm t = return $ rtExp t - --- to normalize records and record types -sortByFst :: Ord a => [(a,b)] -> [(a,b)] -sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) - --- resource - -redParam :: Param -> Err G.ParDef -redParam (c,cont) = do - c' <- redIdent c - cont' <- mapM (redCType . snd) cont - return $ G.ParD c' cont' - -redArgvar :: Ident -> Err G.ArgVar -redArgvar x = case x of - IA (x,i) -> return $ G.A (identC x) (toInteger i) - IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i) - _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable" - -redLindef :: Term -> Err G.Term -redLindef t = case t of - Abs x b -> redCTerm b --- - _ -> redCTerm t - -redCType :: Type -> Err G.CType -redCType t = case t of - RecType lbs -> do - let (ls,ts) = unzip lbs - ls' = map redLabel ls - ts' <- mapM redCType ts - return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts' - Table p v -> liftM2 G.Table (redCType p) (redCType v) - Q m c -> liftM G.Cn $ redQIdent (m,c) - QC m c -> liftM G.Cn $ redQIdent (m,c) - - App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n) - - Sort "Str" -> return $ G.TStr - Sort "Tok" -> return $ G.TStr - _ -> prtBad "cannot reduce to canonical the type" t - -redCTerm :: Term -> Err G.Term -redCTerm t = case t of - Vr x -> checkAgain - (liftM G.Arg $ redArgvar x) - (liftM G.LI $ redIdent x) --- for parametrize optimization - App _ s -> do -- only constructor applications can remain - (_,c,xx) <- termForm t - xx' <- mapM redCTerm xx - case c of - QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx') - Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s - _ -> prtBad "expected constructor head instead of" c - Q p c -> liftM G.I (redQIdent (p,c)) - QC p c -> liftM2 G.Par (redQIdent (p,c)) (return []) - R rs -> do - let (ls,tts) = unzip rs - ls' = map redLabel ls - ts <- mapM (redCTerm . snd) tts - return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts - RecType [] -> return $ G.R [] --- comes out in parsing - P tr l -> do - tr' <- redCTerm tr - return $ G.P tr' (redLabel l) - PI tr l _ -> redCTerm $ P tr l ----- - T i cs -> do - ty <- getTableType i - ty' <- redCType ty - let (ps,ts) = unzip cs - ps' <- mapM redPatt ps - ts' <- mapM redCTerm ts - return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts' - TSh i cs -> do - ty <- getTableType i - ty' <- redCType ty - let (pss,ts) = unzip cs - pss' <- mapM (mapM redPatt) pss - ts' <- mapM redCTerm ts - return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts' - V ty ts -> do - ty' <- redCType ty - ts' <- mapM redCTerm ts - return $ G.V ty' ts' - S u v -> liftM2 G.S (redCTerm u) (redCTerm v) - K s -> return $ G.K (G.KS s) - EInt i -> return $ G.EInt i - EFloat i -> return $ G.EFloat i - C u v -> liftM2 G.C (redCTerm u) (redCTerm v) - FV ts -> liftM G.FV $ mapM redCTerm ts ---- Ready ss -> return $ G.Ready [redStr ss] --- obsolete - - Alts (d,vs) -> do --- - d' <- redCTermTok d - vs' <- mapM redVariant vs - return $ G.K $ G.KP d' vs' - - Empty -> return $ G.E - ---- Strs ss -> return $ G.Strs [s | K s <- ss] --- - ----- Glue obsolete in canon, should not occur here - Glue x y -> redCTerm (C x y) - - _ -> Bad ("cannot reduce term" +++ prt t) - -redPatt :: Patt -> Err G.Patt -redPatt p = case p of - PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) - PR rs -> do - let (ls,tts) = unzip rs - ls' = map redLabel ls - ts <- mapM redPatt tts - return $ G.PR $ map (uncurry G.PAss) $ sortByFst $ zip ls' ts - PT _ q -> redPatt q - PInt i -> return $ G.PI i - PFloat i -> return $ G.PF i - PV x -> liftM G.PV $ redIdent x --- for parametrize optimization - _ -> prtBad "cannot reduce pattern" p - -redLabel :: Label -> G.Label -redLabel (LIdent s) = G.L $ identC s -redLabel (LVar i) = G.LV $ toInteger i - -redVariant :: (Term, Term) -> Err G.Variant -redVariant (v,c) = do - v' <- redCTermTok v - c' <- redCTermTok c - return $ G.Var v' c' - -redCTermTok :: Term -> Err [String] -redCTermTok t = case t of - K s -> return [s] - Empty -> return [] - C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b) - Strs ss -> return [s | K s <- ss] --- - _ -> prtBad "cannot get strings from term" t - diff --git a/src-3.0/GF/Compile/MkConcrete.hs b/src-3.0/GF/Compile/MkConcrete.hs deleted file mode 100644 index d016a7e47..000000000 --- a/src-3.0/GF/Compile/MkConcrete.hs +++ /dev/null @@ -1,154 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkConcrete --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Compile a gfe file into a concrete syntax by using the parser on a resource grammar. ------------------------------------------------------------------------------ - -module GF.Compile.MkConcrete (mkConcretes) where - -import GF.Grammar.Values (Tree,tree2exp) -import GF.Grammar.PrGrammar (prt_,prModule) -import GF.Grammar.Grammar --- (Term(..),SourceModule) -import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent) -import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords) -import GF.Compile.PGrammar (pTerm,pTrm) -import GF.Compile.Compile -import GF.Compile.PrOld (stripTerm) -import GF.Compile.GetGrammar -import GF.API -import GF.API.IOGrammar -import qualified GF.Embed.EmbedAPI as EA - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Infra.Modules -import GF.Infra.ReadFiles -import GF.System.Arch -import GF.UseGrammar.Treebank - -import System.Directory -import System.FilePath -import Data.Char -import Control.Monad -import Data.List - --- translate strings into lin rules by parsing in a resource --- grammar. AR 2/6/2005 - --- Format of rule (on one line): --- lin F x y = in C "ssss" ; --- Format of resource path (on first line): --- --# -resource=PATH --- Other lines are copied verbatim. --- A sequence of files can be processed with the same resource without --- rebuilding the grammar and parser. - --- notice: we use a hand-crafted lexer and parser in order to preserve --- the layout and comments in the rest of the file. - -mkConcretes :: Options -> [FilePath] -> IO () -mkConcretes opts files = do - ress <- mapM getResPath files - let grps = groupBy (\a b -> fst a == fst b) $ - sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files - mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps] - -mkCncGroups opts0 ((res,path),files) = do - putStrLnFlush $ "Going to preprocess examples in " ++ unwords files - putStrLn $ "Compiling resource " ++ res - let opts = addOptions (options [beSilent,pathList path]) opts0 - let treebank = oElem (iOpt "treebank") opts - resf <- useIOE res $ do - (fp,_) <- readFileLibraryIOE "" res - return fp - egr <- appIOE $ shellStateFromFiles opts emptyShellState resf - (parser,morpho) <- if treebank then do - tb <- err (\_ -> error $ "no treebank of name" +++ path) - return - (egr >>= flip findTreebank (zIdent path)) - return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb, - isWordInTreebank tb) - else do - gr <- err (\s -> putStrLn s >> error "resource grammar rejected") - (return . firstStateGrammar) egr - return - (\cat s -> - errVal ([],"No parse") $ - optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>= - (\ (ts,e) -> return (map tree2exp ts, e)) , - isKnownWord gr) - putStrLn "Building parser" - mapM_ (mkConcrete parser morpho) files - -type Parser = String -> String -> ([Term],String) -type Morpho = String -> Bool - -getResPath :: FilePath -> IO (String,String) -getResPath file = do - s <- liftM lines $ readFileIf file - case filter (not . all isSpace) s of - res:path:_ | is "resource" res && is "path" path -> return (val res, val path) - res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path) - res:_ | is "resource" res -> return (val res, "") - _ -> error - "expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT" - where - val = dropWhile (isSpace) . tail . dropWhile (not . (=='=')) - is tag s = case words s of - "--#":w:_ -> isPrefixOf ('-':tag) w - _ -> False - - -mkConcrete :: Parser -> Morpho -> FilePath -> IO () -mkConcrete parser morpho file = do - src <- appIOE (getSourceModule noOptions file) >>= err error return - let (src',msgs) = mkModule parser morpho src - let out = addExtension (justModuleName file) "gf" - writeFile out $ "-- File generated by GF from " ++ file - appendFile out "\n" - appendFile out (prModule src') - appendFile out "{-\n" - appendFile out $ unlines $ filter (not . null) msgs - appendFile out "-}\n" - -mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String]) -mkModule parser morpho (name,src) = case src of - ModMod m@(Module mt st fs me ops js) -> - - let js1 = jments m - (js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) [] - mod2 = ModMod $ Module mt st fs me ops $ js2 - in ((name,mod2), msgs) - where - mkInfo ni@(name,info) = case info of - CncFun mt (Yes trm) ppr -> do - trm' <- mkTrm trm - return (name, CncFun mt (Yes trm') ppr) - _ -> return ni - where - mkTrm t = case t of - Example (P _ cat) s -> parse cat s t - Example (Vr cat) s -> parse cat s t - _ -> composOp mkTrm t - parse cat s t = case parser (prt_ cat) s of - (tr:[], _) -> do - updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++) - return $ stripTerm tr - (tr:trs,_) -> do - updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++) - return $ stripTerm tr - ([],ms) -> do - updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++) - return t - morph s = case [w | w <- words s, not (morpho w)] of - [] -> "" - ws -> "unknown words: " ++ unwords ws diff --git a/src-3.0/GF/Compile/MkResource.hs b/src-3.0/GF/Compile/MkResource.hs deleted file mode 100644 index 10831b5c6..000000000 --- a/src-3.0/GF/Compile/MkResource.hs +++ /dev/null @@ -1,128 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkResource --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 21:08:14 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Compile a gfc module into a "reuse" gfr resource, interface, or instance. ------------------------------------------------------------------------------ - -module GF.Compile.MkResource (makeReuse) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.Lockfield -import GF.Grammar.PrGrammar - -import GF.Data.Operations - -import Control.Monad - --- | extracting resource r from abstract + concrete syntax. --- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules -makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> - MReuseType Ident -> Err SourceRes -makeReuse gr r me mrc = do - flags <- return [] --- no flags are passed: they would not make sense - case mrc of - MRResource c -> do - (ops,jms) <- mkFull True c - return $ Module MTResource MSComplete flags me ops jms - - MRInstance c a -> do - (ops,jms) <- mkFull False c - return $ Module (MTInstance a) MSComplete flags me ops jms - - MRInterface c -> do - mc <- lookupModule gr c - - (ops,jms) <- case mc of - ModMod m -> case mtype m of - MTAbstract -> liftM ((,) (opens m)) $ - mkResDefs True False gr r c me - (extend m) (jments m) emptyBinTree - _ -> prtBad "expected abstract to be the type of" c - _ -> prtBad "expected abstract to be the type of" c - - return $ Module MTInterface MSIncomplete flags me ops jms - - where - mkFull hasT c = do - mc <- lookupModule gr c - - case mc of - ModMod m -> case mtype m of - MTConcrete a -> do - ma <- lookupModule gr a - jmsA <- case ma of - ModMod m' -> return $ jments m' - _ -> prtBad "expected abstract to be the type of" a - liftM ((,) (opens m)) $ - mkResDefs hasT True gr r a me (extend m) jmsA (jments m) - _ -> prtBad "expected concrete to be the type of" c - _ -> prtBad "expected concrete to be the type of" c - - --- | the first Boolean indicates if the type needs be given --- the second Boolean indicates if the definition needs be given -mkResDefs :: Bool -> Bool -> - SourceGrammar -> Ident -> Ident -> - [(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] -> - BinTree Ident Info -> BinTree Ident Info -> - Err (BinTree Ident Info) -mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where - - ifTyped = yes --- if hasT then yes else const nope --- needed for TC - ifCompl = if isC then yes else const nope - doIf b t = if b then t else return typeType -- latter value not used - - mkOne a mae (f,info) = case info of - AbsCat _ _ -> do - typ <- doIf isC $ err (const (return defLinType)) return $ look cnc f - typ' <- doIf isC $ lockRecType f typ - return (f, ResOper (ifTyped typeType) (ifCompl typ')) - AbsFun (Yes typ0) _ -> do - trm <- doIf isC $ look cnc f - testErr (not (isHardType typ0)) - ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0) - typ <- redirTyp True a mae typ0 - cat <- valCat typ - trm' <- doIf isC $ unlockRecord (snd cat) trm - return (f, ResOper (ifTyped typ) (ifCompl trm')) - AnyInd b n -> do - mo <- lookupModMod gr n - info' <- lookupInfo mo f - mkOne n (extend mo) (f,info') - - look cnc f = do - info <- lookupTree prt f cnc - case info of - CncCat (Yes ty) _ _ -> return ty - CncCat _ _ _ -> return defLinType - CncFun _ (Yes tr) _ -> return tr - AnyInd _ n -> do - mo <- lookupModMod gr n - t <- look (jments mo) f - redirTyp False n (extend mo) t - _ -> prtBad "not enough information to reuse" f - - -- type constant qualifications changed from abstract to resource - redirTyp always a mae ty = case ty of - Q _ c | always -> return $ Q r c - Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts - _ -> composOp (redirTyp always a mae) ty - --- | no reuse for functions of HO\/dep types -isHardType t = case t of - Prod x a b -> not (isWild x) || isHardType a || isHardType b - App _ _ -> True - _ -> False - where - isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon diff --git a/src-3.0/GF/Compile/MkUnion.hs b/src-3.0/GF/Compile/MkUnion.hs deleted file mode 100644 index b4b1f40c8..000000000 --- a/src-3.0/GF/Compile/MkUnion.hs +++ /dev/null @@ -1,83 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MkUnion --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:39 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- building union of modules. --- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance ------------------------------------------------------------------------------ - -module GF.Compile.MkUnion (makeUnion) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.PrGrammar - -import GF.Data.Operations -import GF.Infra.Option - -import Data.List -import Control.Monad - -makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] -> - Err SourceModule -makeUnion gr m ty imps = do - ms <- mapM (lookupModMod gr . fst) imps - typ <- return ty ---- getTyp ms - ext <- getExt [i | Just i <- map extends ms] - ops <- return $ nub $ concatMap opens ms - flags <- return $ concatMap flags ms - js <- liftM (buildTree . concat) $ mapM getJments imps - return $ (m, ModMod (Module typ MSComplete flags ext ops js)) - - where - getExt es = case es of - [] -> return Nothing - i:is -> if all (==i) is then return (Just i) - else Bad "different extended modules in union forbidden" - getJments (i,fs) = do - m <- lookupModMod gr i - let js = jments m - if null fs - then - return (map (unqual i) $ tree2list js) - else do - ds <- mapM (flip justLookupTree js) fs - return $ map (unqual i) $ zip fs ds - - unqual i (f,d) = curry id f $ case d of - AbsCat pty pts -> AbsCat (qualCo pty) (qualPs pts) - AbsFun pty pt -> AbsFun (qualP pty) (qualP pt) - AbsTrans t -> AbsTrans $ qual t - ResOper pty pt -> ResOper (qualP pty) (qualP pt) - CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp) - CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp - ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) - ResValue pty -> ResValue (qualP pty) - _ -> d - where - qualP pt = case pt of - Yes t -> yes $ qual t - _ -> pt - qualPs pt = case pt of - Yes ts -> yes $ map qual ts - _ -> pt - qualCo pco = case pco of - Yes co -> yes $ [(x,qual t) | (x,t) <- co] - _ -> pco - qual t = case t of - Q m c | m==i -> Cn c - QC m c | m==i -> Cn c - _ -> composSafeOp qual t - qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co]) - qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t))) - qualLin Nothing = Nothing - diff --git a/src-3.0/GF/Compile/NewRename.hs b/src-3.0/GF/Compile/NewRename.hs deleted file mode 100644 index cec8ed24f..000000000 --- a/src-3.0/GF/Compile/NewRename.hs +++ /dev/null @@ -1,294 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:41 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- AR 14\/5\/2003 --- --- The top-level function 'renameGrammar' does several things: --- --- - extends each module symbol table by indirections to extended module --- --- - changes unqualified and as-qualified imports to absolutely qualified --- --- - goes through the definitions and resolves names --- --- Dependency analysis between modules has been performed before this pass. --- Hence we can proceed by @fold@ing "from left to right". ------------------------------------------------------------------------------ - -module GF.Compile.NewRename (renameSourceTerm, renameModule) where - -import GF.Grammar.Grammar -import GF.Grammar.Values -import GF.Infra.Modules -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Grammar.PrGrammar -import GF.Grammar.AppPredefined -import GF.Grammar.Lookup -import GF.Compile.Extend -import GF.Data.Operations - -import Control.Monad - --- | this gives top-level access to renaming term input in the cc command -renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term -renameSourceTerm g m t = do - mo <- lookupErr m (modules g) - let status = (modules g,(m,mo)) --- <- buildStatus g m mo - renameTerm status [] t - --- | this is used in the compiler, separately for each module -renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] -renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of - ModMod m@(Module mt st fs me ops js) -> do - let js1 = jments m - let status = (ms, (name, mod)) - js2 <- mapMTree (renameInfo status) js1 - let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2 - return $ (name,mod2) : ms - -type Status = ([SourceModule],SourceModule) --- (StatusTree, [(OpenSpec Ident, StatusTree)]) - ---- type StatusTree = BinTree (Ident,StatusInfo) - ---- type StatusInfo = Ident -> Term - -lookupStatusInfo :: Ident -> SourceModule -> Err Term -lookupStatusInfo c (q,ModMod m) = do - i <- lookupTree prt c $ jments m - return $ case i of - AbsFun _ (Yes EData) -> QC q c - ResValue _ -> QC q c - ResParam _ -> QC q c - AnyInd True n -> QC n c --- should go further? - AnyInd False n -> Q n c - _ -> Q q c -lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q - -lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term -lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of - Ok v -> return v - _ -> lookupStatusInfoMany ms c -lookupStatusInfoMany [] x = - prtBad "renaming failed to find unqualified constant" x ----- should also give error if stg is found in more than one module - -renameIdentTerm :: Status -> Term -> Err Term -renameIdentTerm env@(imps,act@(_,ModMod this)) t = - errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $ - case t of - Vr c -> do - f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c - return $ f - Cn c -> do - f <- lookupStatusInfoMany openeds c - return $ f - Q m' c | m' == cPredef {- && isInPredefined c -} -> return t - Q m' c -> do - m <- lookupErr m' qualifs - f <- lookupStatusInfo c m - return $ f - QC m' c | m' == cPredef {- && isInPredefined c -} -> return t - QC m' c -> do - m <- lookupErr m' qualifs - f <- lookupStatusInfo c m - return $ f - _ -> return t - where - openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]] - qualifs = - [(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]] - ++ - [(m, (m,st)) | OSimple _ m <- opens this, Just st <- [lookup m imps]] - -- qualif is always possible - - -- this facility is mainly for BWC with GF1: you need not import PredefAbs - predefAbs c s = case c of - IC "Int" -> return $ Q cPredefAbs cInt - IC "String" -> return $ Q cPredefAbs cString - _ -> Bad s - --- | would it make sense to optimize this by inlining? -renameIdentPatt :: Status -> Patt -> Err Patt -renameIdentPatt env p = do - let t = patt2term p - t' <- renameIdentTerm env t - term2patt t' - -{- deprec ! -info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) -info2status mq (c,i) = (c, case i of - AbsFun _ (Yes EData) -> maybe Con QC mq - ResValue _ -> maybe Con QC mq - ResParam _ -> maybe Con QC mq - AnyInd True m -> maybe Con (const (QC m)) mq - AnyInd False m -> maybe Cn (const (Q m)) mq - _ -> maybe Cn Q mq - ) - -tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo) -tree2status o = case o of - OSimple _ i -> mapTree (info2status (Just i)) - OQualif _ i j -> mapTree (info2status (Just j)) - -buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status -buildStatus gr c mo = let mo' = self2status c mo in case mo of - ModMod m -> do - let gr1 = MGrammar $ (c,mo) : modules gr - ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m - mods <- mapM (lookupModule gr1 . openedModule) ops - let sts = map modInfo2status $ zip ops mods - return $ if isModCnc m - then (NT, reverse sts) -- the module itself does not define any names - else (mo',reverse sts) -- so the empty ident is not needed - -modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) -modInfo2status (o,i) = (o,case i of - ModMod m -> tree2status o (jments m) - ) - -self2status :: Ident -> SourceModInfo -> StatusTree -self2status c i = mapTree (info2status (Just c)) js where -- qualify internal - js = case i of - ModMod m - | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m - | otherwise -> jments m - noTrans (_,d) = case d of -- to enable other than transfer js in transfer module - AbsTrans _ -> False - _ -> True --} - -forceQualif o = case o of - OSimple q i -> OQualif q i i - OQualif q _ i -> OQualif q i i - -renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) -renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ - liftM ((,) i) $ case info of - AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) - (renPerh (mapM rent) pfs) - AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) - AbsTrans f -> liftM AbsTrans (rent f) - - ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) - ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp) - ResValue t -> liftM ResValue (ren t) - CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) - CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) - _ -> return info - where - ren = renPerh rent - rent = renameTerm status [] - -renPerh ren pt = case pt of - Yes t -> liftM Yes $ ren t - _ -> return pt - -renameTerm :: Status -> [Ident] -> Term -> Err Term -renameTerm env vars = ren vars where - ren vs trm = case trm of - Abs x b -> liftM (Abs x) (ren (x:vs) b) - Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) - Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x - | elem x vs -> return trm - | otherwise -> renid trm - Cn _ -> renid trm - Con _ -> renid trm - Q _ _ -> renid trm - QC _ _ -> renid trm - Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs - T i cs -> do - i' <- case i of - TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source - _ -> return i - liftM (T i') $ mapM (renCase vs) cs - - Let (x,(m,a)) b -> do - m' <- case m of - Just ty -> liftM Just $ ren vs ty - _ -> return m - a' <- ren vs a - b' <- ren (x:vs) b - return $ Let (x,(m',a')) b' - - P t@(Vr r) l -- for constant t we know it is projection - | elem r vs -> return trm -- var proj first - | otherwise -> case renid (Q r (label2ident l)) of -- qualif second - Ok t -> return t - _ -> liftM (flip P l) $ renid t -- const proj last - - _ -> composOp (ren vs) trm - - renid = renameIdentTerm env - renCase vs (p,t) = do - (p',vs') <- renpatt p - t' <- ren (vs' ++ vs) t - return (p',t') - renpatt = renamePattern env - --- | vars not needed in env, since patterns always overshadow old vars -renamePattern :: Status -> Patt -> Err (Patt,[Ident]) -renamePattern env patt = case patt of - - PC c ps -> do - c' <- renameIdentTerm env $ Cn c - psvss <- mapM renp ps - let (ps',vs) = unzip psvss - case c' of - QC p d -> return (PP p d ps', concat vs) - Q p d -> return (PP p d ps', concat vs) ---- should not happen - _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) - ----- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps - - PV x -> case renid patt of - Ok p -> return (p,[]) - _ -> return (patt, [x]) - - PR r -> do - let (ls,ps) = unzip r - psvss <- mapM renp ps - let (ps',vs') = unzip psvss - return (PR (zip ls ps'), concat vs') - - _ -> return (patt,[]) - - where - renp = renamePattern env - renid = renameIdentPatt env - -renameParam :: Status -> (Ident, Context) -> Err (Ident, Context) -renameParam env (c,co) = do - co' <- renameContext env co - return (c,co') - -renameContext :: Status -> Context -> Err Context -renameContext b = renc [] where - renc vs cont = case cont of - (x,t) : xts - | isWildIdent x -> do - t' <- ren vs t - xts' <- renc vs xts - return $ (x,t') : xts' - | otherwise -> do - t' <- ren vs t - let vs' = x:vs - xts' <- renc vs' xts - return $ (x,t') : xts' - _ -> return cont - ren = renameTerm b - --- | vars not needed in env, since patterns always overshadow old vars -renameEquation :: Status -> [Ident] -> Equation -> Err Equation -renameEquation b vs (ps,t) = do - (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps - t' <- renameTerm b (concat vs' ++ vs) t - return (ps',t') diff --git a/src-3.0/GF/Compile/NoParse.hs b/src-3.0/GF/Compile/NoParse.hs deleted file mode 100644 index c8f828970..000000000 --- a/src-3.0/GF/Compile/NoParse.hs +++ /dev/null @@ -1,49 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : NoParse --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.1 $ --- --- Probabilistic abstract syntax. AR 30\/10\/2005 --- --- (c) Aarne Ranta 2005 under GNU GPL --- --- Contents: decide what lin rules no parser is generated. --- Usually a list of noparse idents from 'i -boparse=file'. - ------------------------------------------------------------------------------ - -module GF.Compile.NoParse ( - NoParse -- = Ident -> Bool - ,getNoparseFromFile -- :: Opts -> IO NoParse - ,doParseAll -- :: NoParse - ) where - -import GF.Infra.Ident -import GF.Data.Operations -import GF.Infra.Option - - -type NoParse = (Ident -> Bool) - -doParseAll :: NoParse -doParseAll = const False - -getNoparseFromFile :: Options -> FilePath -> IO NoParse -getNoparseFromFile opts file = do - let f = maybe file id $ getOptVal opts noparseFile - s <- readFile f - let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s - tree `seq` return $ igns tree - where - igns tree i = isInBinTree i tree - --- where -getIgnores s = case dropWhile (/="--#") (words s) of - _:"noparse":fs -> map identC fs - _ -> [] diff --git a/src-3.0/GF/Compile/Optimize.hs b/src-3.0/GF/Compile/Optimize.hs deleted file mode 100644 index 8931cb6a2..000000000 --- a/src-3.0/GF/Compile/Optimize.hs +++ /dev/null @@ -1,300 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Optimize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/16 13:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- Top-level partial evaluation for GF source modules. ------------------------------------------------------------------------------ - -module GF.Compile.Optimize (optimizeModule) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.Compute -import GF.Compile.BackOpt -import GF.Compile.CheckGrammar -import GF.Compile.Update -import GF.Compile.Evaluate - -import GF.Data.Operations -import GF.Infra.CheckM -import GF.Infra.Option - -import Control.Monad -import Data.List - -import Debug.Trace - - --- conditional trace - -prtIf :: (Print a) => Bool -> a -> a -prtIf b t = if b then trace (" " ++ prt t) t else t - --- experimental evaluation, option to import -oEval = iOpt "eval" - --- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. --- only do this for resource: concrete is optimized in gfc form -optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> - (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv) -optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | - st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do - (mo1,_) <- evalModule oopts mse mo - let - mo2 = case optim of - "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing - "values" -> shareModule valOpt mo1 -- tables as courses-of-values - "share" -> shareModule shareOpt mo1 -- sharing of branches - "all" -> shareModule allOpt mo1 -- first parametrize then values - "none" -> mo1 -- no optimization - _ -> mo1 -- none; default for src - return (mo2,eenv) - _ -> evalModule oopts mse mo - where - oopts = addOptions opts (iOpts (flagsModule mo)) - optim = maybe "all" id $ getOptVal oopts useOptimizer - -evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> - Err ((Ident,SourceModInfo),EEnv) -evalModule oopts (ms,eenv) mo@(name,mod) = case mod of - - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of - _ | isModRes m0 && not (oElem oEval oopts) -> do - let deps = allOperDependencies name js - ids <- topoSortOpers deps - MGrammar (mod' : _) <- foldM evalOp gr ids - return $ (mod',eenv) - - MTConcrete a | oElem oEval oopts -> do - (js0,eenv') <- appEvalConcrete gr js eenv - js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),eenv') - - MTConcrete a -> do - js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),eenv) - - _ -> return $ ((name,mod),eenv) - _ -> return $ ((name,mod),eenv) - where - gr0 = MGrammar $ ms - gr = MGrammar $ (name,mod) : ms - - evalOp g@(MGrammar ((_, ModMod m) : _)) i = do - info <- lookupTree prt i $ jments m - info' <- evalResInfo oopts gr (i,info) - return $ updateRes g name i info' - --- | only operations need be compiled in a resource, and this is local to each --- definition since the module is traversed in topological order -evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info -evalResInfo oopts gr (c,info) = case info of - - ResOper pty pde -> eIn "operation" $ do - pde' <- case pde of - Yes de | optres -> liftM yes $ comp de - _ -> return pde - return $ ResOper pty pde' - - _ -> return info - where - comp = if optres then computeConcrete gr else computeConcreteRec gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - optim = maybe "all" id $ getOptVal oopts useOptimizer - optres = case optim of - "noexpand" -> False - _ -> True - - -evalCncInfo :: - Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) -evalCncInfo opts gr cnc abs (c,info) = do - - seq (prtIf (oElem beVerbose opts) c) $ return () - - errIn ("optimizing" +++ prt c) $ case info of - - CncCat ptyp pde ppr -> do - pde' <- case (ptyp,pde) of - (Yes typ, Yes de) -> - liftM yes $ pEval ([(varStr, typeStr)], typ) de - (Yes typ, Nope) -> - liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ) - (May b, Nope) -> - return $ May b - _ -> return pde -- indirection - - ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) - - return (c, CncCat ptyp pde' ppr') - - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do - pde' <- case pde of - Yes de | notNewEval -> do - liftM yes $ pEval ty de - - _ -> return pde - ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed - - _ -> return (c,info) - where - pEval = partEval opts gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - notNewEval = not (oElem oEval opts) - --- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do - let vars = map fst context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm3 <- if globalTable - then etaExpand subst trm1 >>= outCase subst - else etaExpand subst trm1 - return $ mkAbs vars trm3 - - where - - globalTable = oElem showAll opts --- i -all - - comp g t = {- refreshTerm t >>= -} computeTerm gr g t - - etaExpand su t = do - t' <- comp su t - case t' of - R _ | rightType t' -> comp su t' --- return t' wo noexpand... - _ -> recordExpand val t' >>= comp su - -- don't eta expand records of right length (correct by type checking) - rightType t = case (t,val) of - (R rs, RecType ts) -> length rs == length ts - _ -> False - - outCase subst t = do - pts <- getParams context - let (args,ptyps) = unzip $ filter (flip occur t . fst) pts - if null args - then return t - else do - let argtyp = RecType $ tuple2recordType ptyps - let pvars = map (Vr . zIdent . prt) args -- gets eliminated - patt <- term2patt $ R $ tuple2record $ pvars - let t' = replace (zip args pvars) t - t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] - return $ S t1 $ R $ tuple2record args - - --- notice: this assumes that all lin types follow the "old JFP style" - getParams = liftM concat . mapM getParam - getParam (argv,RecType rs) = return - [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] - ---getParam (_,ty) | ty==typeStr = return [] --- in lindef - getParam (av,ty) = - Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) - --- all lin types are rec types - - replace :: [(Term,Term)] -> Term -> Term - replace reps trm = case trm of - -- this is the important case - P _ _ -> maybe trm id $ lookup trm reps - _ -> composSafeOp (replace reps) trm - - occur t trm = case trm of - - -- this is the important case - P _ _ -> t == trm - S x y -> occur t y || occur t x - App f x -> occur t x || occur t f - Abs _ f -> occur t f - R rs -> any (occur t) (map (snd . snd) rs) - T _ cs -> any (occur t) (map snd cs) - C x y -> occur t x || occur t y - Glue x y -> occur t x || occur t y - ExtR x y -> occur t x || occur t y - FV ts -> any (occur t) ts - V _ ts -> any (occur t) ts - Let (_,(_,x)) y -> occur t x || occur t y - _ -> False - - --- here we must be careful not to reduce --- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} --- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; - -recordExpand :: Type -> Term -> Err Term -recordExpand typ trm = case unComputed typ of - RecType tys -> case trm of - FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] - _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] - _ -> return trm - - --- | auxiliaries for compiling the resource - -mkLinDefault :: SourceGrammar -> Type -> Err Term -mkLinDefault gr typ = do - case unComputed typ of - RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign) - _ -> prtBad "linearization type must be a record type, not" typ - where - mkDefField typ = case unComputed typ of - Table p t -> do - t' <- mkDefField t - let T _ cs = mkWildCases t' - return $ T (TWild p) cs - Sort "Str" -> return $ Vr varStr - QC q p -> lookupFirstTag gr q p - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM mkDefField ts - return $ R $ [assign l t | (l,t) <- zip ls ts'] - _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> prtBad "linearization type field cannot be" typ - --- | Form the printname: if given, compute. If not, use the computed --- lin for functions, cat name for cats (dispatch made in evalCncDef above). ---- We cannot use linearization at this stage, since we do not know the ---- defaults we would need for question marks - and we're not yet in canon. -evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term -evalPrintname gr c ppr lin = - case ppr of - Yes pr -> comp pr - _ -> case lin of - Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm - _ -> return $ K $ prt c ---- - where - comp = computeConcrete gr - - oneBranch t = case t of - Abs _ b -> oneBranch b - R (r:_) -> oneBranch $ snd $ snd r - T _ (c:_) -> oneBranch $ snd c - V _ (c:_) -> oneBranch c - FV (t:_) -> oneBranch t - C x y -> C (oneBranch x) (oneBranch y) - S x _ -> oneBranch x - P x _ -> oneBranch x - Alts (d,_) -> oneBranch d - _ -> t - - --- very unclean cleaner - clean s = case s of - '+':'+':' ':cs -> clean cs - '"':cs -> clean cs - c:cs -> c: clean cs - _ -> s - diff --git a/src-3.0/GF/Compile/PGrammar.hs b/src-3.0/GF/Compile/PGrammar.hs deleted file mode 100644 index 521f616b5..000000000 --- a/src-3.0/GF/Compile/PGrammar.hs +++ /dev/null @@ -1,77 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/25 10:27:12 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.PGrammar (pTerm, pTrm, pTrms, - pMeta, pzIdent, - string2ident - ) where - ----import LexGF -import GF.Source.ParGF -import GF.Source.SourceToGrammar (transExp) -import GF.Grammar.Grammar -import GF.Infra.Ident -import qualified GF.Canon.AbsGFC as A -import qualified GF.Canon.GFC as G -import GF.Compile.GetGrammar -import GF.Grammar.Macros -import GF.Grammar.MMacros - -import GF.Data.Operations -import qualified Data.ByteString.Char8 as BS - -pTerm :: String -> Err Term -pTerm s = do - e <- pExp $ myLexer (BS.pack s) - transExp e - -pTrm :: String -> Term -pTrm = errVal (vr (zIdent "x")) . pTerm --- - -pTrms :: String -> [Term] -pTrms = map pTrm . sep [] where - sep t cs = case cs of - ',' : cs2 -> reverse t : sep [] cs2 - c : cs2 -> sep (c:t) cs2 - _ -> [reverse t] - -pTrm' :: String -> [Term] -pTrm' = err (const []) singleton . pTerm - -pMeta :: String -> Integer -pMeta _ = 0 --- - -pzIdent :: String -> Ident -pzIdent = zIdent - -{- -string2formsAndTerm :: String -> ([Term],Term) -string2formsAndTerm s = case s of - '[':_:_ -> case span (/=']') s of - (x,_:y) -> (pTrms (tail x), pTrm y) - _ -> ([],pTrm s) - _ -> ([], pTrm s) --} - -string2ident :: String -> Err Ident -string2ident s = return $ string2var s - -{- --- reads the Haskell datatype -readGrammar :: String -> Err GrammarST -readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> return x - [] -> Bad "no parse of Grammar" - _ -> Bad "ambiguous parse of Grammar" --} diff --git a/src-3.0/GF/Compile/PrOld.hs b/src-3.0/GF/Compile/PrOld.hs deleted file mode 100644 index 29920fab6..000000000 --- a/src-3.0/GF/Compile/PrOld.hs +++ /dev/null @@ -1,84 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrOld --- Maintainer : GF --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- a hack to print gf2 into gf1 readable files --- Works only for canonical grammars, printed into GFC. Otherwise we would have --- problems with qualified names. --- --- printnames are not preserved, nor are lindefs ------------------------------------------------------------------------------ - -module GF.Compile.PrOld (printGrammarOld, stripTerm) where - -import GF.Grammar.PrGrammar -import GF.Canon.CanonToGrammar -import qualified GF.Canon.GFC as GFC -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Infra.Modules -import qualified GF.Source.PrintGF as P -import GF.Source.GrammarToSource - -import Data.List -import GF.Data.Operations -import GF.Infra.UseIO - -printGrammarOld :: GFC.CanonGrammar -> String -printGrammarOld gr = err id id $ do - as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m] - cs0 <- mapM canon2sourceModule - [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m] - as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0 - cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0 - return $ unlines $ map prj $ srt as1 ++ srt cs1 - where - js (ModMod m) = jments m - srt = sortBy (\ (i,_) (j,_) -> compare i j) - prj ii = P.printTree $ trAnyDef ii - -stripInfo :: (Ident,Info) -> [(Ident,Info)] -stripInfo (c,i) = case i of - AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope - AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr)) - AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope - ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing)) - CncCat (Yes ty) _ _ -> rc $ - CncCat (Yes (stripTerm ty)) nope nope - CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope - _ -> [] - where - rc j = [(c,j)] - -stripContext co = [(x, stripTerm t) | (x,t) <- co] - -stripTerm :: Term -> Term -stripTerm t = case t of - Q _ c -> Vr c - QC _ c -> Vr c - T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where - ti' = case ti of - TTyped ty -> TTyped $ stripTerm ty - TComp ty -> TComp $ stripTerm ty - TWild ty -> TWild $ stripTerm ty - _ -> ti ----- R [] -> EInt 8 --- GF 1.2 parser doesn't accept empty records ----- RecType [] -> Cn (zIdent "Int") --- - _ -> composSafeOp stripTerm t - -stripPattern p = case p of - PC c [] -> PV c - PP _ c [] -> PV c - PC c ps -> PC c (map stripPattern ps) - PP _ c ps -> PC c (map stripPattern ps) - PR lps -> PR [(l, stripPattern p) | (l,p) <- lps] - PT t p -> PT (stripTerm t) (stripPattern p) - _ -> p - diff --git a/src-3.0/GF/Compile/ShellState.hs b/src-3.0/GF/Compile/ShellState.hs deleted file mode 100644 index 0e24da601..000000000 --- a/src-3.0/GF/Compile/ShellState.hs +++ /dev/null @@ -1,568 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ShellState --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.53 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.ShellState where - -import GF.Data.Operations -import GF.Canon.GFC -import GF.Canon.AbsGFC -import GF.GFCC.CId ---import GF.GFCC.DataGFCC(mkGFCC) -import GF.GFCC.Macros (lookFCFG) -import GF.Canon.CanonToGFCC -import GF.Grammar.Macros -import GF.Grammar.MMacros - -import GF.Canon.Look -import GF.Canon.Subexpressions -import GF.Grammar.LookAbs -import GF.Compile.ModDeps -import GF.Compile.Evaluate -import qualified GF.Infra.Modules as M -import qualified GF.Grammar.Grammar as G -import qualified GF.Grammar.PrGrammar as P -import GF.CF.CF -import GF.CF.CFIdent -import GF.CF.CanonToCF -import GF.UseGrammar.Morphology -import GF.Probabilistic.Probabilistic -import GF.Compile.NoParse -import GF.Infra.Option -import GF.Infra.Ident -import GF.Infra.UseIO (justModuleName) -import GF.System.Arch (ModTime) - -import qualified Transfer.InterpreterAPI as T - -import GF.Formalism.FCFG -import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE -import qualified GF.Conversion.GFC as Cnv -import qualified GF.Conversion.SimpleToFCFG as FCnv -import qualified GF.Parsing.GFC as Prs - -import Control.Monad (mplus) -import Data.List (nub,nubBy) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) - - --- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished - --- | multilingual state with grammars and options -data ShellState = ShSt { - abstract :: Maybe Ident , -- ^ pointer to actual abstract, if not empty st - concrete :: Maybe Ident , -- ^ pointer to primary concrete - concretes :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active - canModules :: CanonGrammar , -- ^ compiled abstracts and concretes - srcModules :: G.SourceGrammar , -- ^ saved resource modules - cfs :: [(Ident,CF)] , -- ^ context-free grammars (small, no parameters, very over-generating) - abstracts :: [(Ident,[Ident])], -- ^ abstracts and their associated concretes - mcfgs :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3) - fcfgs :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov - cfgs :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg - -- (large, with parameters, no-so overgenerating) - pInfos :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars) - morphos :: [(Ident,Morpho)], -- ^ morphologies - treebanks :: [(Ident,Treebank)], -- ^ treebanks - probss :: [(Ident,Probs)], -- ^ probability distributions - gloptions :: Options, -- ^ global options - readFiles :: [(String,(FilePath,ModTime))],-- ^ files read - absCats :: [(G.Cat,(G.Context, - [(G.Fun,G.Type)], - [((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts, - -- functions to them, - -- functions on them) - statistics :: [Statistics], -- ^ statistics on grammars - transfers :: [(Ident,T.Env)], -- ^ transfer modules - evalEnv :: EEnv -- ^ evaluation environment - } - -type Treebank = Map.Map String [String] -- string, trees - -actualConcretes :: ShellState -> [((Ident,Ident),Bool)] -actualConcretes sh = nub [((c,c),b) | - Just a <- [abstract sh], - ((c,_),_) <- concretes sh, ----concretesOfAbstract sh a, - let b = True ----- - ] - -concretesOfAbstract :: ShellState -> Ident -> [Ident] -concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs] - -data Statistics = - StDepTypes Bool -- ^ whether there are dependent types - | StBoundVars [G.Cat] -- ^ which categories have bound variables - --- -- etc - deriving (Eq,Ord) - -emptyShellState :: ShellState -emptyShellState = ShSt { - abstract = Nothing, - concrete = Nothing, - concretes = [], - canModules = M.emptyMGrammar, - srcModules = M.emptyMGrammar, - cfs = [], - abstracts = [], - mcfgs = [], - fcfgs = [], - cfgs = [], - pInfos = [], - morphos = [], - treebanks = [], - probss = [], - gloptions = noOptions, - readFiles = [], - absCats = [], - statistics = [], - transfers = [], - evalEnv = emptyEEnv - } - -optInitShellState :: Options -> ShellState -optInitShellState os = addGlobalOptions os emptyShellState - -type Language = Ident - -language :: String -> Language -language = identC - -prLanguage :: Language -> String -prLanguage = prIdent - --- | grammar for one language in a state, comprising its abs and cnc -data StateGrammar = StGr { - absId :: Ident, - cncId :: Ident, - grammar :: CanonGrammar, - cf :: CF, - mcfg :: Cnv.MGrammar, - fcfg :: FGrammar, - cfg :: Cnv.CGrammar, - pInfo :: Prs.PInfo, - morpho :: Morpho, - probs :: Probs, - loptions :: Options - } - -emptyStateGrammar :: StateGrammar -emptyStateGrammar = StGr { - absId = identC "#EMPTY", --- - cncId = identC "#EMPTY", --- - grammar = M.emptyMGrammar, - cf = emptyCF, - mcfg = [], - fcfg = ([], Map.empty), - cfg = [], - pInfo = Prs.buildPInfo [] ([], Map.empty) [], - morpho = emptyMorpho, - probs = emptyProbs, - loptions = noOptions - } - --- analysing shell grammar into parts - -stateGrammarST :: StateGrammar -> CanonGrammar -stateCF :: StateGrammar -> CF -stateMCFG :: StateGrammar -> Cnv.MGrammar -stateFCFG :: StateGrammar -> FGrammar -stateCFG :: StateGrammar -> Cnv.CGrammar -statePInfo :: StateGrammar -> Prs.PInfo -stateMorpho :: StateGrammar -> Morpho -stateProbs :: StateGrammar -> Probs -stateOptions :: StateGrammar -> Options -stateGrammarWords :: StateGrammar -> [String] -stateGrammarLang :: StateGrammar -> (CanonGrammar, Ident) - -stateGrammarST = grammar -stateCF = cf -stateMCFG = mcfg -stateFCFG = fcfg -stateCFG = cfg -statePInfo = pInfo -stateMorpho = morpho -stateProbs = probs -stateOptions = loptions -stateGrammarWords = allMorphoWords . stateMorpho -stateGrammarLang st = (grammar st, cncId st) - ----- this should be computed at compile time and stored -stateHasHOAS :: StateGrammar -> Bool -stateHasHOAS = hasHOAS . stateGrammarST - -cncModuleIdST :: StateGrammar -> CanonGrammar -cncModuleIdST = stateGrammarST - --- | form a shell state from a canonical grammar -grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState -grammar2shellState opts (gr,sgr) = - updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe? - --- | update a shell state from a canonical grammar -updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState -> - ((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) -> - Err ShellState -updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do - let cgr0 = M.updateMGrammar (canModules sh) gr - - -- a0 = abstract of old state - -- a1 = abstract of compiled grammar - - let a0 = abstract sh - a1 <- return $ case mcnc of - Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc - _ -> M.greatestAbstract cgr0 - - -- abstr0 = a1 if it exists - - let (abstr0,isNew) = case (a0,a1) of - (Just a, Just b) | a /= b -> (a1, True) - (Nothing, Just _) -> (a1, True) - _ -> (a0, False) - - let concrs0 = maybe [] (M.allConcretes cgr0) abstr0 - - let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ - maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh - - let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0) - purge = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo))) - - let cgr = M.MGrammar $ purge $ M.modules cgr0 - - let oldConcrs = map (snd . fst) (concretes sh) - newConcrs = maybe [] (M.allConcretes gr) abstr0 - toRetain (c,v) = notElem c newConcrs - let complete m = case M.lookupModule gr m of - Ok mo -> not $ isIncompleteCanon (m,mo) - _ -> False - - let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs - concr0 = ifNull Nothing (return . head) concrs - notInrts f = notElem f $ map fst rts - subcgr = unSubelimCanon cgr - cf's0 <- if (not (oElem (iOpt "docf") opts) && -- cf only built with -docf - (oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf - then return $ map snd $ cfs sh - else mapM (canon2cf opts ign subcgr) newConcrs - let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh) - - let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh) - let probss = [] ----- - - - let fromGFC = snd . snd . Cnv.convertGFC opts - (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs - gfcc = canon2gfcc opts cgr ---- UTF8 - fcfgs = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]] - pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs - - let funs = funRulesOf cgr - let cats = allCatsOf cgr - let csi = [(c,(co, - [(fun,typ) | (fun,typ) <- funs, compatType tc typ], - funsOnTypeFs compatType funs tc)) - | (c,co) <- cats, let tc = cat2val co c] - let deps = True ---- not $ null $ allDepCats cgr - let binds = [] ---- allCatsWithBind cgr - let src = M.updateMGrammar (srcModules sh) sgr - - return $ ShSt { - abstract = abstr0, - concrete = concr0, - concretes = zip (zip concrs concrs) (repeat True), - canModules = cgr, - srcModules = src, - cfs = cf's, - abstracts = maybe [] (\a -> [(a,concrs)]) abstr0, - mcfgs = zip concrs mcfgs, - fcfgs = fcfgs, - cfgs = zip concrs cfgs, - pInfos = zip concrs pInfos, - morphos = morphs, - treebanks = treebanks sh, - probss = zip concrs probss, - gloptions = gloptions sh, --- opts, -- this would be command-line options - readFiles = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts, - absCats = csi, - statistics = [StDepTypes deps,StBoundVars binds], - transfers = transfers sh, - evalEnv = eenv - } - -prShellStateInfo :: ShellState -> String -prShellStateInfo sh = unlines [ - "main abstract : " +++ abstractName sh, - "main concrete : " +++ maybe "(none)" P.prt (concrete sh), - "actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)), - "all abstracts : " +++ unwords (map (P.prt . fst) (abstracts sh)), - "all concretes : " +++ unwords (map (P.prt . fst . fst) (concretes sh)), - "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))), - "source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))), - "global options : " +++ prOpts (gloptions sh), - "transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)), - "treebanks : " +++ unwords (map (P.prt . fst) (treebanks sh)) - ] - -abstractName :: ShellState -> String -abstractName sh = maybe "(none)" P.prt (abstract sh) - --- | throw away those abstracts that are not needed --- could be more aggressive -filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar -filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where - ms = M.modules cgr - needed (i,_) = elem i needs - needs = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts] - dep i a = elem i (ext mse a) - mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]] - ext es a = case lookup a es of - Just e -> a : concatMap (ext es) e ---- FIX multiple exts - _ -> [] - -purgeShellState :: ShellState -> ShellState -purgeShellState sh = ShSt { - abstract = abstr, - concrete = concrete sh, - concretes = concrs, - canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh, - srcModules = M.emptyMGrammar, - cfs = cfs sh, - abstracts = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr, - mcfgs = mcfgs sh, - fcfgs = fcfgs sh, - cfgs = cfgs sh, - pInfos = pInfos sh, - morphos = morphos sh, - treebanks = treebanks sh, - probss = probss sh, - gloptions = gloptions sh, - readFiles = [], - absCats = absCats sh, - statistics = statistics sh, - transfers = transfers sh, - evalEnv = emptyEEnv - } - where - abstr = abstract sh - concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed] - isSingle = length (abstracts sh) == 1 - needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh) - complete = not . isIncompleteCanon - -changeMain :: Maybe Ident -> ShellState -> Err ShellState -changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = - return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) -changeMain - (Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = - case lookup c (M.modules ms) of - Just _ -> do - a <- M.abstractOfConcrete ms c - let cas = M.allConcretes ms a - let cs' = [((c,c),True) | c <- cas] - return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs - pinfos mos tbs pbs os rs acs s trs ee) - _ -> P.prtBad "The state has no concrete syntax named" c - --- | form just one state grammar, if unique, from a canonical grammar -grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar -grammar2stateGrammar opts gr = do - st <- grammar2shellState opts (gr,M.emptyMGrammar) - concr <- maybeErr "no concrete syntax" $ concrete st - return $ stateGrammarOfLang st concr - -resourceOfShellState :: ShellState -> Maybe Ident -resourceOfShellState = M.greatestResource . srcModules - -qualifTop :: StateGrammar -> G.QIdent -> G.QIdent -qualifTop gr (_,c) = (absId gr,c) - -stateGrammarOfLang :: ShellState -> Language -> StateGrammar -stateGrammarOfLang = stateGrammarOfLangOpt True - -stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar -stateGrammarOfLangOpt purg st0 l = StGr { - absId = err (const (identC "Abs")) id $ M.abstractOfConcrete allCan l, --- - cncId = l, - grammar = allCan, - cf = maybe emptyCF id (lookup l (cfs st)), - mcfg = maybe [] id $ lookup l $ mcfgs st, - fcfg = maybe ([],Map.empty) id $ lookup l $ fcfgs st, - cfg = maybe [] id $ lookup l $ cfgs st, - pInfo = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st, - morpho = maybe emptyMorpho id (lookup l (morphos st)), - probs = maybe emptyProbs id (lookup l (probss st)), - loptions = errVal noOptions $ lookupOptionsCan allCan - } - where - st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0 - allCan = canModules st - -grammarOfLang :: ShellState -> Language -> CanonGrammar -cfOfLang :: ShellState -> Language -> CF -morphoOfLang :: ShellState -> Language -> Morpho -probsOfLang :: ShellState -> Language -> Probs -optionsOfLang :: ShellState -> Language -> Options - -grammarOfLang st = stateGrammarST . stateGrammarOfLang st -cfOfLang st = stateCF . stateGrammarOfLang st -morphoOfLang st = stateMorpho . stateGrammarOfLang st -probsOfLang st = stateProbs . stateGrammarOfLang st -optionsOfLang st = stateOptions . stateGrammarOfLang st - -removeLang :: Language -> ShellState -> ShellState -removeLang lang st = purgeShellState $ st{concretes = concs1} where - concs1 = filter ((/=lang) . snd . fst) $ concretes st - --- | the last introduced grammar, stored in options, is the default for operations -firstStateGrammar :: ShellState -> StateGrammar -firstStateGrammar st = errVal (stateAbstractGrammar st) $ do - concr <- maybeErr "no concrete syntax" $ concrete st - return $ stateGrammarOfLang st concr - -mkStateGrammar :: ShellState -> Language -> StateGrammar -mkStateGrammar = stateGrammarOfLang - -stateAbstractGrammar :: ShellState -> StateGrammar -stateAbstractGrammar st = StGr { - absId = maybe (identC "Abs") id (abstract st), --- - cncId = identC "#Cnc", --- - grammar = canModules st, ---- only abstarct ones - cf = emptyCF, - mcfg = [], - fcfg = ([],Map.empty), - cfg = [], - pInfo = Prs.buildPInfo [] ([],Map.empty) [], - morpho = emptyMorpho, - probs = emptyProbs, - loptions = gloptions st ---- - } - - --- analysing shell state into parts - -globalOptions :: ShellState -> Options -allLanguages :: ShellState -> [Language] -allTransfers :: ShellState -> [Ident] -allCategories :: ShellState -> [G.Cat] -allStateGrammars :: ShellState -> [StateGrammar] -allStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)] -allGrammarFileNames :: ShellState -> [String] -allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)] -allActiveGrammars :: ShellState -> [StateGrammar] - -globalOptions = gloptions ---allLanguages = map (fst . fst) . concretes -allLanguages = map (snd . fst) . actualConcretes -allTransfers = map fst . transfers -allCategories = map fst . allCatsOf . canModules - -allStateGrammars = map snd . allStateGrammarsWithNames - -allStateGrammarsWithNames st = - [(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st] - -allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st] - -allActiveStateGrammarsWithNames st = - [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual - -allActiveGrammars = map snd . allActiveStateGrammarsWithNames - -pathOfModule :: ShellState -> Ident -> FilePath -pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh - --- command-line option -lang=foo overrides the actual grammar in state -grammarOfOptState :: Options -> ShellState -> StateGrammar -grammarOfOptState opts st = - maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ - getOptVal opts useLanguage - -languageOfOptState :: Options -> ShellState -> Maybe Language -languageOfOptState opts st = - maybe (concrete st) (return . language) $ getOptVal opts useLanguage - --- | command-line option -cat=foo overrides the possible start cat of a grammar -firstCatOpts :: Options -> StateGrammar -> CFCat -firstCatOpts opts sgr = - maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ - getOptVal opts firstCat - --- | the first cat for random generation -firstAbsCat :: Options -> StateGrammar -> G.QIdent -firstAbsCat opts = cfCat2Cat . firstCatOpts opts - --- | Gets the start category for the grammar from the options. --- If the startcat is not set in the options, we look --- for a flag in the grammar. If there is no flag in the --- grammar, S is returned. -startCatStateOpts :: Options -> StateGrammar -> CFCat -startCatStateOpts opts sgr = - string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat)) - where optsStartCat = getOptVal opts gStartCat - grStartCat = getOptVal (stateOptions sgr) gStartCat - a = P.prt (absId sgr) - --- | a grammar can have start category as option startcat=foo ; default is S -stateFirstCat :: StateGrammar -> CFCat -stateFirstCat = startCatStateOpts noOptions - -stateIsWord :: StateGrammar -> String -> Bool -stateIsWord sg = isKnownWord (stateMorpho sg) - -addProbs :: (Ident,Probs) -> ShellState -> Err ShellState -addProbs ip@(lang,probs) sh = do - let gr = grammarOfLang sh lang - probs' <- checkGrammarProbs gr probs - let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh) - return $ sh{probss = pbs'} - -addTransfer :: (Ident,T.Env) -> ShellState -> ShellState -addTransfer it@(i,_) sh = - sh {transfers = it : filter ((/= i) . fst) (transfers sh)} - -addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState -addTreebanks its sh = sh {treebanks = its ++ treebanks sh} - -findTreebank :: ShellState -> Ident -> Err Treebank -findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh - --- modify state - -type ShellStateOper = ShellState -> ShellState -type ShellStateOperErr = ShellState -> Err ShellState - -reinitShellState :: ShellStateOper -reinitShellState = const emptyShellState - -languageOn, languageOff :: Language -> ShellStateOper -languageOn = languageOnOff True -languageOff = languageOnOff False - -languageOnOff :: Bool -> Language -> ShellStateOper ---- __________ this is OBSOLETE -languageOnOff b lang sh = sh {concretes = cs'} where - cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh] - -changeOptions :: (Options -> Options) -> ShellStateOper ---- __________ this is OBSOLETE -changeOptions f sh = sh {gloptions = f (gloptions sh)} - -addGlobalOptions :: Options -> ShellStateOper -addGlobalOptions = changeOptions . addOptions - -removeGlobalOptions :: Options -> ShellStateOper -removeGlobalOptions = changeOptions . removeOptions - diff --git a/src-3.0/GF/Compile/Wordlist.hs b/src-3.0/GF/Compile/Wordlist.hs deleted file mode 100644 index 3fbc066bd..000000000 --- a/src-3.0/GF/Compile/Wordlist.hs +++ /dev/null @@ -1,108 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Wordlist --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Compile a gfwl file (multilingual word list) to an abstract + concretes ------------------------------------------------------------------------------ - -module GF.Compile.Wordlist (mkWordlist) where - -import GF.Data.Operations -import GF.Infra.UseIO -import Data.List -import Data.Char -import System.FilePath - --- read File.gfwl, write File.gf (abstract) and a set of concretes --- return the names of the concretes - -mkWordlist :: FilePath -> IO [FilePath] -mkWordlist file = do - s <- readFileIf file - let abs = dropExtension file - let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s - let (gr,grs) = mkGrammars abs cnchs wlist - let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs] - mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs - putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs) - return cncfs - -{- --- syntax of files, e.g. - - # Svenska - Franska - Finska -- names of concretes - - berg - montagne - vuori -- word entry - --- this creates: - - cat S ; - fun berg_S : S ; - lin berg_S = {s = ["berg"]} ; - lin berg_S = {s = ["montagne"]} ; - lin berg_S = {s = ["vuori"]} ; - --- support for different categories to be elaborated. The syntax it - - Verb . klättra - grimper / escalader - kiivetä / kiipeillä - --- notice that a word can have several alternative (separator /) --- and that an alternative can consist of several words --} - -type CncHeader = (String,String) -- module name, module header - -type Wordlist = [(String, [[String]])] -- cat, variants for each cnc - - -pWordlist :: String -> [String] -> ([CncHeader],Wordlist) -pWordlist abs ls = (headers,rules) where - (hs,rs) = span ((=="#") . take 1) ls - headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs - rules = map (mkRule . words) rs - - mkHeader ws = case ws of - w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2)) - mkRule ws = case ws of - cat:".":vs -> (cat, mkWords vs) - _ -> ("S", mkWords ws) - mkWords = map (map unwords . chunks "/") . chunks "-" - - -mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String]) -mkGrammars ab hs wl = (abs,cncs) where - abs = unlines $ map unwords $ - ["abstract",ab,"=","{"]: - cats ++ - funs ++ - [["}"]] - - cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss] - - cats = [["cat",c,";"] | c <- nub $ map fst wl] - funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf] - - wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl] - - rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]] - - lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"] - - val ss = case ss of - [w] -> quote w - _ -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}" - - quote w = "[" ++ prQuotedString w ++ "]" - - ident f c = concat $ intersperse "_" $ words (head f) ++ [c] - - -notComment s = not (all isSpace s) && take 2 s /= "--" - diff --git a/src-3.0/GF/Conversion/GFC.hs b/src-3.0/GF/Conversion/GFC.hs deleted file mode 100644 index 354bdea65..000000000 --- a/src-3.0/GF/Conversion/GFC.hs +++ /dev/null @@ -1,157 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/01 09:53:18 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.14 $ --- --- All conversions from GFC ------------------------------------------------------------------------------ - -module GF.Conversion.GFC - (module GF.Conversion.GFC, - SGrammar, EGrammar, MGrammar, CGrammar) where - -import GF.Infra.Option -import GF.Canon.GFC (CanonGrammar) -import GF.Infra.Ident (Ident, identC) -import qualified GF.Infra.Modules as M - -import GF.Formalism.GCFG (Rule(..), Abstract(..)) -import GF.Formalism.SimpleGFC (decl2cat) -import GF.Formalism.CFG (CFRule(..)) -import GF.Formalism.Utilities (symbol, name2fun) -import GF.Conversion.Types - -import qualified GF.Conversion.GFCtoSimple as G2S -import qualified GF.Conversion.SimpleToFinite as S2Fin -import qualified GF.Conversion.RemoveSingletons as RemSing -import qualified GF.Conversion.RemoveErasing as RemEra -import qualified GF.Conversion.RemoveEpsilon as RemEps -import qualified GF.Conversion.SimpleToMCFG as S2M -import qualified GF.Conversion.MCFGtoCFG as M2C - -import GF.Infra.Print - -import GF.System.Tracing - ----------------------------------------------------------------------- --- * GFC -> MCFG & CFG, using options to decide which conversion is used - -convertGFC :: Options -> (CanonGrammar, Ident) - -> (SGrammar, (EGrammar, (MGrammar, CGrammar))) -convertGFC opts = \g -> let s = g2s g - e = s2e s - m = e2m e - in trace2 "Options" (show opts) (s, (e, (m, e2c e))) - where e2c = M2C.convertGrammar - e2m = case getOptVal opts firstCat of - Just cat -> flip erasing [identC cat] - Nothing -> flip erasing [] - s2e = case getOptVal opts gfcConversion of - Just "strict" -> strict - Just "finite-strict" -> strict - Just "epsilon" -> epsilon . nondet - _ -> nondet - g2s = case getOptVal opts gfcConversion of - Just "finite" -> finite . simple - Just "finite2" -> finite . finite . simple - Just "finite3" -> finite . finite . finite . simple - Just "singletons" -> single . simple - Just "finite-singletons" -> single . finite . simple - Just "finite-strict" -> finite . simple - _ -> simple - - simple = G2S.convertGrammar - strict = S2M.convertGrammarStrict - nondet = S2M.convertGrammarNondet - epsilon = RemEps.convertGrammar - finite = S2Fin.convertGrammar - single = RemSing.convertGrammar - erasing = RemEra.convertGrammar - -gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar -gfc2simple opts = fst . convertGFC opts - -gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar -gfc2mcfg opts g = mcfg - where - (mcfg, _) = snd (snd (convertGFC opts g)) - -gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar -gfc2cfg opts g = cfg - where - (_, cfg) = snd (snd (convertGFC opts g)) - - ----------------------------------------------------------------------- --- * single step conversions - -{- -gfc2simple :: (CanonGrammar, Ident) -> SGrammar -gfc2simple = G2S.convertGrammar - -simple2finite :: SGrammar -> SGrammar -simple2finite = S2Fin.convertGrammar - -removeSingletons :: SGrammar -> SGrammar -removeSingletons = RemSing.convertGrammar - -simple2mcfg_nondet :: SGrammar -> EGrammar -simple2mcfg_nondet = - -simple2mcfg_strict :: SGrammar -> EGrammar -simple2mcfg_strict = S2M.convertGrammarStrict - -mcfg2cfg :: EGrammar -> CGrammar -mcfg2cfg = M2C.convertGrammar - -removeErasing :: EGrammar -> [SCat] -> MGrammar -removeErasing = RemEra.convertGrammar - -removeEpsilon :: EGrammar -> EGrammar -removeEpsilon = RemEps.convertGrammar --} - ----------------------------------------------------------------------- --- * converting to some obscure formats - -gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun] -gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) | - Rule (Abs decl decls name) _ <- G2S.convertGrammar gr ] - -abstract2skvatt :: [Abstract SCat Fun] -> String -abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr - where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++ - "\"" ++ prt fun ++ "\".\n" - abs2pl (Abs cat cats fun) = - prtQuoted cat ++ " ---> " ++ - "\"(" ++ prt fun ++ "\"" ++ - prtBefore ", \" \", " (map prtQuoted cats) ++ ", \")\".\n" - -cfg2skvatt :: CGrammar -> String -cfg2skvatt gr = skvatt_hdr ++ concatMap cfg2pl gr - where cfg2pl (CFRule cat syms _name) = - prtQuoted cat ++ " ---> " ++ - if null syms then "\"\".\n" else - prtSep ", " (map (symbol prtQuoted prTok) syms) ++ ".\n" - prTok tok = "\"" ++ tok ++ " \"" - -skvatt_hdr = ":- use_module(library(skvatt)).\n" ++ - ":- use_module(library(utils), [repeat/1]).\n" ++ - "corpus(File, StartCat, Depth, Size) :- \n" ++ - " set_flag(gendepth, Depth),\n" ++ - " tell(File), repeat(Size),\n" ++ - " generate_words(StartCat, String), format('~s~n~n', [String]),\n" ++ - " write(user_error, '.'),\n" ++ - " fail ; told.\n\n" - -prtQuoted :: Print a => a -> String -prtQuoted a = "'" ++ prt a ++ "'" - - - - diff --git a/src-3.0/GF/Conversion/GFCtoSimple.hs b/src-3.0/GF/Conversion/GFCtoSimple.hs deleted file mode 100644 index b6a34a8ce..000000000 --- a/src-3.0/GF/Conversion/GFCtoSimple.hs +++ /dev/null @@ -1,175 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/07 11:24:51 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.15 $ --- --- Converting GFC to SimpleGFC --- --- the conversion might fail if the GFC grammar has dependent or higher-order types, --- or if the grammar contains bound pattern variables --- (use -optimize=values/share/none when importing) --- --- TODO: lift all functions to the 'Err' monad ------------------------------------------------------------------------------ - -module GF.Conversion.GFCtoSimple - (convertGrammar) where - -import qualified GF.Canon.AbsGFC as A -import qualified GF.Infra.Ident as I -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Formalism.Utilities -import GF.Conversion.Types - -import GF.UseGrammar.Linear (expandLinTables) -import GF.Canon.GFC (CanonGrammar) -import GF.Canon.MkGFC (grammar2canon) -import GF.Canon.Subexpressions (unSubelimCanon) -import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat) -import qualified GF.Canon.CMacros as CMacros (defLinType) -import GF.Data.Operations (err, errVal) ---import qualified Modules as M - -import GF.System.Tracing -import GF.Infra.Print - ----------------------------------------------------------------------- - -type Env = (CanonGrammar, I.Ident) - -convertGrammar :: Env -> SGrammar -convertGrammar (g,i) = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $ - tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $ - [ convertAbsFun gram fun typing | - A.Mod (A.MTAbs modname) _ _ _ defs <- modules, - A.AbsDFun fun typing _ <- defs ] - where A.Gr modules = grammar2canon (fst gram) - gram = (unSubelimCanon g,i) - -convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule -convertAbsFun gram fun typing = -- trace2 "GFCtoSimple - converting function" (prt fun) $ - Rule abs cnc - where abs = convertAbstract [] fun typing - cnc = convertConcrete gram abs - ----------------------------------------------------------------------- --- abstract definitions - -convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name -convertAbstract env fun (A.EProd x a b) - = convertAbstract (convertAbsType x' [] a : env) fun b - where x' = if x==I.identC "h_" then anyVar else x -convertAbstract env fun a - = Abs (convertAbsType anyVar [] a) (reverse env) name - where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ] - -convertAbsType :: Var -> [FOType SCat] -> A.Exp -> SDecl -convertAbsType x args (A.EProd _ a b) = convertAbsType x (convertType [] a : args) b -convertAbsType x args a = Decl x (reverse args ::--> convertType [] a) - -convertType :: [TTerm] -> A.Exp -> FOType SCat -convertType args (A.EApp a b) = convertType (convertExp [] b : args) a -convertType args (A.EAtom at) = convertCat at ::@ reverse args -convertType args (A.EProd _ _ b) = convertType args b ---- AR 7/10 workaround -convertType args exp = error $ "GFCtoSimple.convertType: " ++ prt exp - -{- Exp from GF/Canon/GFC.cf: -EApp. Exp1 ::= Exp1 Exp2 ; -EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ; -EAbs. Exp ::= "\\" Ident "->" Exp ; -EAtom. Exp2 ::= Atom ; -EData. Exp2 ::= "data" ; --} - -convertExp :: [TTerm] -> A.Exp -> TTerm -convertExp args (A.EAtom at) = convertAtom args at -convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a -convertExp args exp = error $ "GFCtoSimple.convertExp: " ++ prt exp - -convertAtom :: [TTerm] -> A.Atom -> TTerm -convertAtom args (A.AC con) = con :@ reverse args --- A.AD: is this correct??? -convertAtom args (A.AD con) = con :@ args -convertAtom [] (A.AV var) = TVar var -convertAtom args atom = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ show atom - -convertCat :: A.Atom -> SCat -convertCat (A.AC (A.CIQ _ cat)) = cat -convertCat atom = error $ "GFCtoSimple.convertCat: " ++ show atom - ----------------------------------------------------------------------- --- concrete definitions - -convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm) -convertConcrete gram (Abs decl args name) = Cnc ltyp largs term - where term = fmap (convertTerm gram . expandTerm gram) $ lookupLin gram $ name2fun name - ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args) - -expandTerm :: Env -> A.Term -> A.Term -expandTerm gram term = -- tracePrt "expanded term" prt $ - err error id $ expandLinTables (fst gram) $ - -- tracePrt "initial term" prt $ - term - -convertCType :: Env -> A.CType -> SLinType -convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ] -convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt) -convertCType gram ct@(A.Cn con) = ConT $ map (convertTerm gram) $ groundTerms gram ct -convertCType gram (A.TStr) = StrT -convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor" - -convertTerm :: Env -> A.Term -> STerm -convertTerm gram (A.Arg arg) = convertArgVar arg -convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms --- convertTerm gram (A.LI var) = Var var -convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ] -convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl -convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) | - (pat, term) <- zip (groundTerms gram ctype) terms ] -convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) | - A.Cas pats term <- tbl, pat <- pats ] -convertTerm gram (A.S term sel) = convertTerm gram term :! convertTerm gram sel -convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2 -convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms) -convertTerm gram (A.E) = Empty -convertTerm gram (A.K (A.KS tok)) = Token tok --- 'pre' tokens are converted to variants (over-generating): -convertTerm gram (A.K (A.KP strs vars)) - = variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ] - where conc [] = Empty - conc ts = foldr1 (?++) $ map Token ts -convertTerm gram (A.I con) = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor" -convertTerm gram (A.EInt int) = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor" - -convertArgVar :: A.ArgVar -> STerm -convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath -convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath - -convertPatt (A.PC con pats) = con :^ map convertPatt pats --- convertPatt (A.PV x) = Var x --- convertPatt (A.PW) = Wildcard -convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ] -convertPatt (A.PI n) = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor" -convertPatt p = error $ "GFCtoSimple.convertPatt: cannot handle " ++ show p - ----------------------------------------------------------------------- - -lookupLin :: Env -> Fun -> Maybe A.Term -lookupLin gram fun = err fail Just $ - Look.lookupLin (fst gram) (A.CIQ (snd gram) fun) - -lookupCType :: Env -> SDecl -> A.CType -lookupCType env decl - = errVal CMacros.defLinType $ - Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl)) - -groundTerms :: Env -> A.CType -> [A.Term] -groundTerms gram ctype = err error id $ - Look.allParamValues (fst gram) ctype - diff --git a/src-3.0/GF/Conversion/Haskell.hs b/src-3.0/GF/Conversion/Haskell.hs deleted file mode 100644 index abe651e1e..000000000 --- a/src-3.0/GF/Conversion/Haskell.hs +++ /dev/null @@ -1,71 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/11 14:11:46 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Converting/Printing different grammar formalisms in Haskell-readable format ------------------------------------------------------------------------------ - - -module GF.Conversion.Haskell where - -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Formalism.MCFG -import GF.Formalism.CFG -import GF.Formalism.Utilities -import GF.Conversion.Types -import GF.Data.Operations ((++++), (+++++)) -import GF.Infra.Print - -import Data.List (intersperse) - --- | SimpleGFC to Haskell -prtSGrammar :: SGrammar -> String -prtSGrammar rules = "-- Simple GFC grammar as a Haskell file" ++++ - "-- Autogenerated from the Grammatical Framework" +++++ - "import GF.Formalism.GCFG" ++++ - "import GF.Formalism.SimpleGFC" ++++ - "import GF.Formalism.Utilities" ++++ - "import GF.Canon.AbsGFC (CIdent(..), Label(..))" ++++ - "import GF.Infra.Ident (Ident(..))" +++++ - "grammar :: SimpleGrammar Ident (NameProfile Ident) String" ++++ - "grammar = \n\t[ " ++ - concat (intersperse "\n\t, " (map show rules)) ++ "\n\t]\n\n" - --- | MCFG to Haskell -prtMGrammar :: MGrammar -> String -prtMGrammar rules = "-- Multiple context-free grammar as a Haskell file" ++++ - "-- Autogenerated from the Grammatical Framework" +++++ - "import GF.Formalism.GCFG" ++++ - "import GF.Formalism.MCFG" ++++ - "import GF.Formalism.Utilities" +++++ - "grammar :: MCFGrammar String (NameProfile String) String String" ++++ - "grammar = \n\t[ " ++ - concat (intersperse "\n\t, " (map prtMRule rules)) ++ "\n\t]\n\n" - where prtMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc lcat lcats lins)) - = show (Rule (Abs (prt cat) (map prt cats) (Name (prt fun) (map cnvProfile profiles))) - (Cnc (map prt lcat) (map (map prt) lcats) (map cnvLin lins))) - cnvLin (Lin lbl syms) = Lin (prt lbl) (map (mapSymbol prtMArg id) syms) - prtMArg (cat, lbl, nr) = (prt cat, prt lbl, nr) - --- | CFG to Haskell -prtCGrammar :: CGrammar -> String -prtCGrammar rules = "-- Context-free grammar as a Haskell file" ++++ - "-- autogenerated from the Grammatical Framework" +++++ - "import GF.Formalism.CFG" ++++ - "import GF.Formalism.Utilities" ++++ - "\ngrammar :: CFGrammar String (NameProfile String) String" ++++ - "grammar = \n\t[ " ++ - concat (intersperse "\n\t, " (map prtCRule rules)) ++ "\n\t]\n\n" - where prtCRule (CFRule cat syms (Name fun profiles)) - = show (CFRule (prt cat) (map (mapSymbol prt id) syms) - (Name (prt fun) (map cnvProfile profiles))) - -cnvProfile (Unify args) = Unify args -cnvProfile (Constant forest) = Constant (fmap prt forest) diff --git a/src-3.0/GF/Conversion/MCFGtoCFG.hs b/src-3.0/GF/Conversion/MCFGtoCFG.hs deleted file mode 100644 index a58c31d37..000000000 --- a/src-3.0/GF/Conversion/MCFGtoCFG.hs +++ /dev/null @@ -1,53 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:43 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.6 $ --- --- Converting MCFG grammars to (possibly overgenerating) CFG ------------------------------------------------------------------------------ - - -module GF.Conversion.MCFGtoCFG - (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import Control.Monad -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.CFG -import GF.Conversion.Types - ----------------------------------------------------------------------- --- * converting (possibly erasing) MCFG grammars - -convertGrammar :: EGrammar -> CGrammar -convertGrammar gram = tracePrt "MCFGtoCFG - context-free rules" (prt.length) $ - concatMap convertRule gram - -convertRule :: ERule -> [CRule] -convertRule (Rule (Abs cat args (Name fun mprofile)) (Cnc _ _ record)) - = [ CFRule (CCat cat lbl) rhs (Name fun profile) | - Lin lbl lin <- record, - let rhs = map (mapSymbol convertArg id) lin, - let cprofile = map (Unify . argPlaces lin) [0 .. length args-1], - let profile = mprofile `composeProfiles` cprofile - ] - -convertArg :: (ECat, ELabel, Int) -> CCat -convertArg (cat, lbl, _) = CCat cat lbl - -argPlaces :: [Symbol (cat, lbl, Int) tok] -> Int -> [Int] -argPlaces lin nr = [ place | (nr', place) <- zip linArgs [0..], nr == nr' ] - where linArgs = [ nr' | (_, _, nr') <- filterCats lin ] - - - - diff --git a/src-3.0/GF/Conversion/MCFGtoFCFG.hs b/src-3.0/GF/Conversion/MCFGtoFCFG.hs deleted file mode 100644 index 70aa4644d..000000000 --- a/src-3.0/GF/Conversion/MCFGtoFCFG.hs +++ /dev/null @@ -1,51 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:43 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.6 $ --- --- Converting MCFG grammars to equivalent optimized FCFG ------------------------------------------------------------------------------ - - -module GF.Conversion.MCFGtoFCFG - (convertGrammar) where - -import Control.Monad -import List (elemIndex) -import Array - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.FCFG -import GF.Conversion.Types -import GF.Data.SortedList (nubsort) - -import GF.Infra.Print - ----------------------------------------------------------------------- --- * converting MCFG to optimized FCFG - -convertGrammar :: MGrammar -> FGrammar -convertGrammar gram = [ FRule (Abs (fcat cat) (map fcat cats) name) (fcnc cnc) | - Rule (Abs cat cats name) cnc <- gram ] - where mcats = nubsort [ mc | Rule (Abs mcat mcats _) _ <- gram, mc <- mcat:mcats ] - - fcat mcat@(MCat (ECat scat ecns) mlbls) - = case elemIndex mcat mcats of - Just catid -> FCat catid scat mlbls ecns - Nothing -> error ("MCFGtoFCFG.fcat " ++ prt mcat) - - fcnc (Cnc _ arglbls lins) = listArray (0, length lins-1) (map flin lins) - where flin (Lin _ syms) = listArray (0, length syms-1) (map fsym syms) - fsym (Tok tok) = FSymTok tok - fsym (Cat (cat,lbl,arg)) = FSymCat (fcat cat) (flbl arg lbl) arg - flbl arg lbl = case elemIndex lbl (arglbls !! arg) of - Just lblid -> lblid - Nothing -> error ("MCFGtoFCFG.flbl " ++ prt arg ++ " " ++ prt lbl) - diff --git a/src-3.0/GF/Conversion/Prolog.hs b/src-3.0/GF/Conversion/Prolog.hs deleted file mode 100644 index b930cb476..000000000 --- a/src-3.0/GF/Conversion/Prolog.hs +++ /dev/null @@ -1,205 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/14 09:51:18 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- Converting/Printing different grammar formalisms in Prolog-readable format ------------------------------------------------------------------------------ - - -module GF.Conversion.Prolog (prtSGrammar, prtSMulti, prtSHeader, prtSRule, - prtMGrammar, prtMMulti, prtMHeader, prtMRule, - prtCGrammar, prtCMulti, prtCHeader, prtCRule) where - -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Formalism.MCFG -import GF.Formalism.CFG -import GF.Formalism.Utilities -import GF.Conversion.Types -import qualified GF.Conversion.GFC as Cnv - -import GF.Data.Operations ((++++), (+++++)) -import GF.Infra.Print -import qualified GF.Infra.Modules as Mod -import qualified GF.Infra.Option as Option -import GF.Data.Operations (okError) -import GF.Canon.AbsGFC (Flag(..)) -import GF.Canon.GFC (CanonGrammar) -import GF.Infra.Ident (Ident(..)) - -import Data.Maybe (maybeToList, listToMaybe) -import Data.Char (isLower, isAlphaNum) - -import GF.System.Tracing - ----------------------------------------------------------------------- --- | printing multiple languages at the same time - -prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String -prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple "gfc_" -prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg "mcfg_" -prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg "cfg_" - --- code and ideas stolen from GF.CFGM.PrintCFGrammar - -prtMulti prtHeader prtRule conversion prefix opts gr - = prtHeader ++++ unlines - [ "\n\n" ++ prtLine ++++ - "%% Language module: " ++ prtQ langmod +++++ - unlines (map (prtRule langmod) rules) | - lang <- maybe [] (Mod.allConcretes gr) (Mod.greatestAbstract gr), - let Mod.ModMod (Mod.Module{Mod.flags=fs}) = okError (Mod.lookupModule gr lang), - let cnvopts = Option.Opts $ map Option.gfcConversion $ getFlag fs "conversion", - let rules = conversion cnvopts (gr, lang), - let langmod = (let IC lg = lang in prefix ++ lg) ] - -getFlag :: [Flag] -> String -> [String] -getFlag fs x = [v | Flg (IC k) (IC v) <- fs, k == x] - ----------------------------------------------------------------------- --- | SimpleGFC to Prolog --- --- assumes that the profiles in the Simple GFC names are trivial -prtSGrammar :: SGrammar -> String -prtSGrammar rules = prtSHeader +++++ unlines (map (prtSRule "") rules) - -prtSHeader :: String -prtSHeader = prtLine ++++ - "%% Simple GFC grammar in Prolog-readable format" ++++ - "%% Autogenerated from the Grammatical Framework" +++++ - "%% The following predicate is defined:" ++++ - "%% \t rule(Fun, Cat, c(Cat,...), LinTerm)" - -prtSRule :: String -> SRule -> String -prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm)) - = (if null lang then "" else prtQ lang ++ " : ") ++ - prtFunctor "rule" [plfun, plcat, plcats, plcnc] ++ "." - where plfun = prtQ fun - plcat = prtSDecl cat - plcats = prtFunctor "c" (map prtSDecl cats) - plcnc = "\n\t" ++ prtSTerm (maybe Empty id mterm) - -prtSTerm (Arg n c p) = prtFunctor "arg" [prtQ c, prt (n+1), prtSPath p] --- prtSTerm (c :^ []) = prtQ c -prtSTerm (c :^ ts) = prtOper "^" (prtQ c) (prtPList (map prtSTerm ts)) -prtSTerm (Rec rec) = prtFunctor "rec" [prtPList [ prtOper "=" (prtQ l) (prtSTerm t) | (l, t) <- rec ]] -prtSTerm (Tbl tbl) = prtFunctor "tbl" [prtPList [ prtOper "=" (prtSTerm p) (prtSTerm t) | (p, t) <- tbl ]] -prtSTerm (Variants ts) = prtFunctor "variants" [prtPList (map prtSTerm ts)] -prtSTerm (t1 :++ t2) = prtOper "+" (prtSTerm t1) (prtSTerm t2) -prtSTerm (Token t) = prtFunctor "tok" [prtQ t] -prtSTerm (Empty) = "empty" -prtSTerm (term :. lbl) = prtOper "*" (prtSTerm term) (prtQ lbl) -prtSTerm (term :! sel) = prtOper "/" (prtSTerm term) (prtSTerm sel) --- prtSTerm (Wildcard) = "wildcard" --- prtSTerm (Var var) = prtFunctor "var" [prtQ var] - -prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path) - -prtSDecl (Decl var typ) | var == anyVar = prtSAbsType typ - | otherwise = "_" ++ prtVar var ++ ":" ++ prtSAbsType typ - - -prtSAbsType ([] ::--> typ) = prtSFOType typ -prtSAbsType (args ::--> typ) = prtOper ":->" (prtPList (map prtSFOType args)) (prtSFOType typ) - -prtSFOType (cat ::@ args) = prtFunctor (prtQ cat) (map prtSTTerm args) - -prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args) -prtSTTerm (TVar var) = "_" ++ prtVar var - ----------------------------------------------------------------------- --- | MCFG to Prolog -prtMGrammar :: MGrammar -> String -prtMGrammar rules = prtMHeader +++++ unlines (map (prtMRule "") rules) - -prtMHeader :: String -prtMHeader = prtLine ++++ - "%% Multiple context-free grammar in Prolog-readable format" ++++ - "%% Autogenerated from the Grammatical Framework" +++++ - "%% The following predicate is defined:" ++++ - "%% \t rule(Profile, Cat, c(Cat,...), [Lbl=Symbols,...])" - -prtMRule :: String -> MRule -> String -prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins)) - = (if null lang then "" else prtQ lang ++ " : ") ++ - prtFunctor "rule" [plname, plcat, plcats, pllins] ++ "." - where plname = prtName name - plcat = prtQ cat - plcats = prtFunctor "c" (map prtQ cats) - pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]" - -prtMLin (Lin lbl lin) = prtOper "=" (prtQ lbl) (prtPList (map prtMSymbol lin)) - -prtMSymbol (Cat (cat, lbl, nr)) = prtFunctor "arg" [prtQ cat, show (nr+1), prtQ lbl] -prtMSymbol (Tok tok) = prtFunctor "tok" [prtQ tok] - ----------------------------------------------------------------------- --- | CFG to Prolog -prtCGrammar :: CGrammar -> String -prtCGrammar rules = prtCHeader +++++ unlines (map (prtCRule "") rules) - -prtCHeader :: String -prtCHeader = prtLine ++++ - "%% Context-free grammar in Prolog-readable format" ++++ - "%% Autogenerated from the Grammatical Framework" +++++ - "%% The following predicate is defined:" ++++ - "%% \t rule(Profile, Cat, [Symbol,...])" - -prtCRule :: String -> CRule -> String -prtCRule lang (CFRule cat syms name) - = (if null lang then "" else prtQ lang ++ " : ") ++ - prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "." - where plname = prtName name - plcat = prtQ cat - plsyms = prtPList (map prtCSymbol syms) - -prtCSymbol (Cat cat) = prtFunctor "cat" [prtQ cat] -prtCSymbol (Tok tok) = prtFunctor "tok" [prtQ tok] - ----------------------------------------------------------------------- --- profiles, quoted strings and more - -prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")" -prtPList xs = "[" ++ prtSep ", " xs ++ "]" -prtOper f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")" - -prtName name@(Name fun profiles) - | name == coercionName = "1" - | and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun - | otherwise = prtFunctor (prtQ fun) (map prtProfile profiles) - -prtProfile (Unify []) = " ? " -prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . succ) args) -prtProfile (Constant forest) = prtForest forest - -prtForest (FMeta) = " ? " -prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (map prtForest fs) -prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (map prtForest fs) | - fs <- fss ] - -prtQ atom = prtQStr (prt atom) - -prtQStr atom@(x:xs) - | isLower x && all isAlphaNumUnder xs = atom - where isAlphaNumUnder '_' = True - isAlphaNumUnder x = isAlphaNum x -prtQStr atom = "'" ++ concatMap esc (prt atom) ++ "'" - where esc '\'' = "\\'" - esc '\n' = "\\n" - esc '\t' = "\\t" - esc c = [c] - -prtVar var = reprime (prt var) - where reprime "" = "" - reprime ('\'' : cs) = "_0" ++ reprime cs - reprime (c:cs) = c : reprime cs - -prtLine = replicate 70 '%' - - diff --git a/src-3.0/GF/Conversion/RemoveEpsilon.hs b/src-3.0/GF/Conversion/RemoveEpsilon.hs deleted file mode 100644 index 0e5dafb38..000000000 --- a/src-3.0/GF/Conversion/RemoveEpsilon.hs +++ /dev/null @@ -1,46 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 08:11:32 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Removing epsilon linearizations from MCF grammars ------------------------------------------------------------------------------ - - -module GF.Conversion.RemoveEpsilon where --- (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import Control.Monad -import Data.List (mapAccumL) -import Data.Maybe (mapMaybe) -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Conversion.Types -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Data.GeneralDeduction - -convertGrammar :: EGrammar -> EGrammar -convertGrammar grammar = trace2 "RemoveEpsilon: initialEmpties" (prt initialEmpties) $ - trace2 "RemoveEpsilon: emptyCats" (prt emptyCats) $ - grammar - where initialEmpties = nubsort [ (cat, lbl) | - Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar, - Lin lbl [] <- lins ] - emptyCats = limitEmpties initialEmpties - limitEmpties es = if es==es' then es else limitEmpties es' - where es' = nubsort [ (cat, lbl) | Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar, - Lin lbl rhs <- lins, - all (symbol (\(c,l,n) -> (c,l) `elem` es) (const False)) rhs ] - - - diff --git a/src-3.0/GF/Conversion/RemoveErasing.hs b/src-3.0/GF/Conversion/RemoveErasing.hs deleted file mode 100644 index 1dc2560fc..000000000 --- a/src-3.0/GF/Conversion/RemoveErasing.hs +++ /dev/null @@ -1,113 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1) ------------------------------------------------------------------------------ - - -module GF.Conversion.RemoveErasing - (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import Control.Monad -import Data.List (mapAccumL) -import Data.Maybe (mapMaybe) -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Conversion.Types -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Data.GeneralDeduction - -convertGrammar :: EGrammar -> [SCat] -> MGrammar -convertGrammar grammar starts = newGrammar - where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $ - [ rule | NR rule <- chartLookup finalChart True ] - finalChart = tracePrt "RemoveErasing - nonerasing cats" - (prt . length . flip chartLookup False) $ - buildChart keyof [newRules rulesByCat] $ - tracePrt "RemoveErasing - initial ne-cats" (prt . length) $ - initialCats - initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $ - if null starts - then trace2 "RemoveErasing" "initialCatsBU" $ - initialCatsBU rulesByCat - else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $ - initialCatsTD rulesByCat starts - rulesByCat = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $ - accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ] - -data Item r c = NR r | NC c deriving (Eq, Ord, Show) - -keyof (NR _) = True -keyof (NC _) = False - -newRules grammar chart (NR (Rule (Abs _ cats _) _)) - = [ NC cat | cat@(MCat _ lbls) <- cats, not (null lbls) ] -newRules grammar chart (NC newCat@(MCat cat lbls)) - = do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat - - lins <- selectLins lins0 lbls - -- let lins = [ lin | lin@(Lin lbl _) <- lins0, - -- lbl `elem` lbls ] - - let argsInLin = listAssoc $ - map (\((n,c),l) -> (n, MCat c l)) $ - groupPairs $ nubsort $ - [ ((nr, cat), lbl) | - Lin _ lin <- lins, - Cat (cat, lbl, nr) <- lin ] - - newArgs = mapMaybe (lookupAssoc argsInLin) [0 .. length args-1] - argLbls = [ lbls | MCat _ lbls <- newArgs ] - - newLins = [ Lin lbl newLin | Lin lbl lin <- lins, - let newLin = map (mapSymbol cnvCat id) lin ] - cnvCat (cat, lbl, nr) = (mcat, lbl, nr') - where Just mcat = lookupAssoc argsInLin nr - Unify [nr'] = newProfile !! nr - nonEmptyCat (Cat (MCat _ [], _, _)) = False - nonEmptyCat _ = True - - newProfile = snd $ mapAccumL accumProf 0 $ - map (lookupAssoc argsInLin) [0 .. length args-1] - accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr]) - newName = -- tracePrt "newName" (prtNewName profile newProfile) $ - Name fun (profile `composeProfiles` newProfile) - - guard $ all (not . null) argLbls - return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins)) - -selectLins lins0 = mapM selectLbl - where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ] - - -prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String -prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n - - -initialCatsTD grammar starts = - [ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar, - start `elem` starts ] - -initialCatsBU grammar - = [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar, - let Rule _ (Cnc lbls _ _) = head rules, - lbl <- lbls ] - - - - - - - diff --git a/src-3.0/GF/Conversion/RemoveSingletons.hs b/src-3.0/GF/Conversion/RemoveSingletons.hs deleted file mode 100644 index 4b9992a4d..000000000 --- a/src-3.0/GF/Conversion/RemoveSingletons.hs +++ /dev/null @@ -1,82 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/11 10:28:16 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- Instantiating all types which only have one single element. --- --- Should be merged into 'GF.Conversion.FiniteToSimple' ------------------------------------------------------------------------------ - -module GF.Conversion.RemoveSingletons where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Conversion.Types - -import GF.Data.SortedList -import GF.Data.Assoc - -import Data.List (mapAccumL) - -convertGrammar :: SGrammar -> SGrammar -convertGrammar grammar = if singles == emptyAssoc then grammar - else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $ - map (convertRule singles) grammar - where singles = calcSingletons grammar - -convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule -convertRule singles rule@(Rule (Abs _ decls _) _) - = if all (Nothing ==) singleArgs then rule - else instantiateSingles singleArgs rule - where singleArgs = map (lookupAssoc singles . decl2cat) decls - -instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule -instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm)) - = Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm') - where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ] - profile' = map (fmap fst) exProfile `composeProfiles` profile - newArgs = map (fmap snd) exProfile - lterm' = fmap (instantiateLin newArgs) lterm - exProfile = snd $ mapAccumL mkProfile 0 singleArgs - mkProfile nr (Just trm) = (nr, Constant trm) - mkProfile nr (Nothing) = (nr+1, Unify [nr]) - -instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm -instantiateLin newArgs = inst - where inst (Arg nr cat path) - = case newArgs !! nr of - Unify [nr'] -> Arg nr' cat path - Constant (Just term) -> termFollowPath path term - Constant Nothing -> error "RemoveSingletons.instantiateLin: This should not happen (argument has no linearization)" - inst (cn :^ terms) = cn :^ map inst terms - inst (Rec rec) = Rec [ (lbl, inst term) | (lbl, term) <- rec ] - inst (term :. lbl) = inst term +. lbl - inst (Tbl tbl) = Tbl [ (pat, inst term) | (pat, term) <- tbl ] - inst (term :! sel) = inst term +! inst sel - inst (Variants ts) = variants (map inst ts) - inst (t1 :++ t2) = inst t1 ?++ inst t2 - inst term = term - ----------------------------------------------------------------------- - -calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm) -calcSingletons rules = listAssoc singleCats - where singleCats = tracePrt "RemoveSingletons - singleton cats" (prtSep " ") $ - [ (cat, (constantNameToForest name, lin)) | - (cat, [([], name, lin)]) <- rulesByCat ] - rulesByCat = groupPairs $ nubsort - [ (decl2cat cat, (args, name, lin)) | - Rule (Abs cat args name) (Cnc _ _ lin) <- rules ] - - - diff --git a/src-3.0/GF/Conversion/SimpleToFinite.hs b/src-3.0/GF/Conversion/SimpleToFinite.hs deleted file mode 100644 index bbd3ae355..000000000 --- a/src-3.0/GF/Conversion/SimpleToFinite.hs +++ /dev/null @@ -1,178 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/01 09:53:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.7 $ --- --- Calculating the finiteness of each type in a grammar ------------------------------------------------------------------------------ - -module GF.Conversion.SimpleToFinite - (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Formalism.Utilities -import GF.Conversion.Types - -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Data.BacktrackM -import GF.Data.Utilities (lookupList) - -import GF.Infra.Ident (Ident(..)) - -type CnvMonad a = BacktrackM () a - -convertGrammar :: SGrammar -> SGrammar -convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $ - solutions cnvMonad () - where split = calcSplitable rules - cnvMonad = member rules >>= convertRule split - -convertRule :: Splitable -> SRule -> CnvMonad SRule -convertRule split (Rule abs cnc) - = do newAbs <- convertAbstract split abs - return $ Rule newAbs cnc - -{- --- old code -convertAbstract :: Splitable -> Abstract SDecl Name - -> CnvMonad (Abstract SDecl Name) -convertAbstract split (Abs decl decls name) - = case splitableFun split (name2fun name) of - Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name - Nothing -> expandTyping split name [] decl decls [] - - -expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl] - -> CnvMonad (Abstract SDecl Name) -expandTyping split name env (Decl x cat args) [] decls - = return $ Abs decl (reverse decls) name - where decl = substArgs split x env cat args [] -expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone - = do (x', xcat', env') <- calcNewEnv - let decl = substArgs split x' env xcat' xargs [] - expandTyping split name env' typ declsToDo (decl : declsDone) - where calcNewEnv = case splitableCat split xcat of - Just newFuns -> do newFun <- member newFuns - let newCat = mergeFun newFun xcat - -- Just newCats -> do newCat <- member newCats - return (anyVar, newCat, (x,newCat) : env) - Nothing -> return (x, xcat, env) --} - --- new code -convertAbstract :: Splitable -> Abstract SDecl Name - -> CnvMonad (Abstract SDecl Name) -convertAbstract split (Abs decl decls name) - = case splitableFun split fun of - Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name - Nothing -> expandTyping split [] fun profiles [] decl decls [] - where Name fun profiles = name - -expandTyping :: Splitable -> [(Var, SCat)] - -> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] - -> SDecl -> [SDecl] -> [SDecl] - -> CnvMonad (Abstract SDecl Name) -expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls - = return $ Abs decl (reverse decls) (Name fun (reverse profiles)) - where decl = substArgs split x env typargs cat args [] -expandTyping split env fun (prof:profiles) profsDone typ - (Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone - = do (x', xcat', env', prof') <- calcNewEnv - let decl = substArgs split x' env xtypargs xcat' xargs [] - expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone) - where calcNewEnv = case splitableCat split xcat of - Nothing -> return (x, xcat, env, prof) - Just newFuns -> do newFun <- member newFuns - let newCat = mergeFun newFun xcat - newProf = Constant (FNode newFun [[]]) - -- should really be using some kind of - -- "profile unification" - return (anyVar, newCat, (x,newCat) : env, newProf) - -substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat] - -> SCat -> [TTerm] -> [TTerm] -> SDecl -substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args)) -substArgs split x env typargs cat (arg:argsToDo) argsDone - = case argLookup split env arg of - Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone - Nothing -> substArgs split x env typargs cat argsToDo (arg : argsDone) - -argLookup split env (TVar x) = lookup x env -argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun) - where fun = constr2fun con - - ----------------------------------------------------------------------- --- splitable categories (finite, no dependencies) --- they should also be used as some dependency - -type Splitable = (Assoc SCat [Fun], Assoc Fun SCat) - -splitableCat :: Splitable -> SCat -> Maybe [Fun] -splitableCat = lookupAssoc . fst - -splitableFun :: Splitable -> Fun -> Maybe SCat -splitableFun = lookupAssoc . snd - -calcSplitable :: [SRule] -> Splitable -calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) - where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns - - splitableFun2Cat = nubsort - [ (fun, cat) | (cat, fun) <- splitableCatFuns ] - - -- cat-fun pairs that are splitable - splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $ - [ (cat, name2fun name) | - Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules, - splitableCats ?= cat ] - - -- all cats that are splitable - splitableCats = listSet $ - tracePrt "SimpleToFinite - finite categories to split" prt $ - (nondepCats <**> depCats) <\\> resultCats - - -- all result cats for some pure function - resultCats = tracePrt "SimpleToFinite - result cats" prt $ - nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules, - not (null decls) ] - - -- all cats in constants without dependencies - nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $ - nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ] - - -- all cats occurring as some dependency of another cat - depCats = tracePrt "SimpleToFinite - dep cats" prt $ - nubsort [ cat | Rule (Abs decl decls _) _ <- rules, - cat <- varCats [] (decls ++ [decl]) ] - - varCats _ [] = [] - varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls) - = varCats ((x,xcat) : env) decls ++ - [ cat | (_::@args) <- (xtyp:xargs), arg <- args, - y <- varsInTTerm arg, cat <- lookupList y env ] - - ----------------------------------------------------------------------- --- utilities --- mergeing categories - -mergeCats :: String -> String -> String -> SCat -> SCat -> SCat -mergeCats before middle after (IC cat) (IC arg) - = IC (before ++ cat ++ middle ++ arg ++ after) - -mergeFun, mergeArg :: SCat -> SCat -> SCat -mergeFun = mergeCats "{" ":" "}" -mergeArg = mergeCats "" "" "" - - diff --git a/src-3.0/GF/Conversion/SimpleToMCFG.hs b/src-3.0/GF/Conversion/SimpleToMCFG.hs deleted file mode 100644 index 8f23c905d..000000000 --- a/src-3.0/GF/Conversion/SimpleToMCFG.hs +++ /dev/null @@ -1,26 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/18 14:55:32 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- All different conversions from SimpleGFC to MCFG ------------------------------------------------------------------------------ - -module GF.Conversion.SimpleToMCFG where - -import GF.Formalism.SimpleGFC -import GF.Conversion.Types - -import qualified GF.Conversion.SimpleToMCFG.Strict as Strict -import qualified GF.Conversion.SimpleToMCFG.Nondet as Nondet -import qualified GF.Conversion.SimpleToMCFG.Coercions as Coerce - -convertGrammarNondet, convertGrammarStrict :: SGrammar -> EGrammar -convertGrammarNondet = Coerce.addCoercions . Nondet.convertGrammar -convertGrammarStrict = Strict.convertGrammar - diff --git a/src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs b/src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs deleted file mode 100644 index 319b99dcb..000000000 --- a/src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs +++ /dev/null @@ -1,63 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- Adding coercion functions to a MCFG if necessary. ------------------------------------------------------------------------------ - - -module GF.Conversion.SimpleToMCFG.Coercions - (addCoercions) where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Conversion.Types -import GF.Data.SortedList -import Data.List (groupBy) - ----------------------------------------------------------------------- - -addCoercions :: EGrammar -> EGrammar -addCoercions rules = coercions ++ rules - where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | - Rule (Abs head args _) (Cnc lbls _ _) <- rules ] - allHeadSet = nubsort allHeads - allArgSet = union allArgs <\\> map fst allHeadSet - coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $ - concat $ - tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category" - (prtList . map length) $ - combineCoercions - (groupBy sameECatFst allHeadSet) - (groupBy sameECat allArgSet) - sameECatFst a b = sameECat (fst a) (fst b) - - -combineCoercions [] _ = [] -combineCoercions _ [] = [] -combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) - = case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of - LT -> combineCoercions allHeads allArgs' - GT -> combineCoercions allHeads' allArgs - EQ -> makeCoercion heads args : combineCoercions allHeads allArgs - - -makeCoercion heads args - = [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins) | - (head@(ECat _ headCns), lbls) <- heads, - let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], - arg@(ECat _ argCns) <- args, - argCns `subset` headCns ] - - - diff --git a/src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs b/src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs deleted file mode 100644 index d6ff052f5..000000000 --- a/src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs +++ /dev/null @@ -1,256 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/17 08:27:29 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.7 $ --- --- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. --- Afterwards, the grammar has to be extended with coercion functions, --- from the module 'GF.Conversion.SimpleToMCFG.Coercions' --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. ------------------------------------------------------------------------------ - - -module GF.Conversion.SimpleToMCFG.Nondet - (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import Control.Monad - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.SimpleGFC -import GF.Conversion.Types - -import GF.Data.BacktrackM -import GF.Data.Utilities (notLongerThan, updateNthM) - ------------------------------------------------------------- --- type declarations - -type CnvMonad a = BacktrackM Env a - -type Env = (ECat, [ECat], LinRec, [SLinType]) -- variable bindings: [(Var, STerm)] -type LinRec = [Lin SCat MLabel Token] - - ----------------------------------------------------------------------- --- main conversion function - -maxNrRules :: Int -maxNrRules = 5000 - -convertGrammar :: SGrammar -> EGrammar -convertGrammar rules = traceCalcFirst rules' $ - tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $ - rules' - where rules' = rules >>= convertRule --- solutions conversion undefined --- where conversion = member rules >>= convertRule - -convertRule :: SRule -> [ERule] -- CnvMonad ERule -convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) = --- | prt(name2fun fun) `elem` --- words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" = - if notLongerThan maxNrRules rules - then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $ - rules - else trace2 "SimpeToMCFG.Nondet - TOO MANY RULES, function not converted" - ("More than " ++ show maxNrRules ++ " MCFG rules for " ++ prt fun) $ - [] - where rules = flip solutions undefined $ - do let cat : args = map decl2cat (decl : decls) - writeState (initialECat cat, map initialECat args, [], ctypes) - rterm <- simplifyTerm term - reduceTerm ctype emptyPath rterm - (newCat, newArgs, linRec, _) <- readState - let newLinRec = map (instantiateArgs newArgs) linRec - catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes) - -- checkLinRec argsPaths catPaths newLinRec - return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) -convertRule _ = [] -- failure - - ----------------------------------------------------------------------- --- "type-checking" the resulting linearization --- should not be necessary, if the algorithms (type-checking and conversion) are correct - -checkLinRec args lbls = mapM (checkLin args lbls) - -checkLin args lbls (Lin lbl lin) - | lbl `elem` lbls = mapM (symbol (checkArg args) (const (return ()))) lin - | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" "Label mismatch" $ - failure - -checkArg args (_cat, lbl, nr) - | lbl `elem` (args !! nr) = return () --- | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" ("Label mismatch in arg " ++ prt nr) $ --- failure - | otherwise = trace2 ("SimpleToMCFG.Nondet - ERROR: Label mismatch in arg " ++ prt nr) - (prt lbl ++ " `notElem` " ++ prt (args!!nr)) $ - failure - - ----------------------------------------------------------------------- --- term simplification - -simplifyTerm :: STerm -> CnvMonad STerm -simplifyTerm (term :! sel) - = do sterm <- simplifyTerm term - ssel <- simplifyTerm sel - case sterm of - Tbl table -> do (pat, val) <- member table - pat =?= ssel - return val - _ -> do sel' <- expandTerm ssel - return (sterm +! sel') --- simplifyTerm (Var x) = readBinding x -simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms -simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record -simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term -simplifyTerm (Tbl table) = liftM Tbl $ mapM simplifyCase table -simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms -simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2) -simplifyTerm term = return term - -simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm) -simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term - -simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm) -simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) - - ------------------------------------------------------------- --- reducing simplified terms, collecting MCF rules - -reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad () ---reduceTerm ctype path (Variants terms) --- = member terms >>= reduceTerm ctype path -reduceTerm (StrT) path term = updateLin (path, term) -reduceTerm (ConT _) path term = do pat <- expandTerm term - updateHead (path, pat) -reduceTerm (RecT rtype) path term - = sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | (lbl, ctype) <- rtype ] -reduceTerm (TblT pats vtype) path table - = sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ] - - ------------------------------------------------------------- --- expanding a term to ground terms - -expandTerm :: STerm -> CnvMonad STerm -expandTerm arg@(Arg nr _ path) - = do ctypes <- readArgCTypes - unifyPType arg $ lintypeFollowPath path $ ctypes !! nr --- expandTerm arg@(Arg nr _ path) --- = do ctypes <- readArgCTypes --- pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr --- pat =?= arg --- return pat -expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms -expandTerm (Rec record) = liftM Rec $ mapM expandAssign record ---expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms -expandTerm (Variants terms) = member terms >>= expandTerm -expandTerm term = error $ "expandTerm: " ++ prt term - -expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) -expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term - -unifyPType :: STerm -> SLinType -> CnvMonad STerm -unifyPType arg (RecT prec) = - liftM Rec $ - sequence [ liftM ((,) lbl) $ - unifyPType (arg +. lbl) ptype | - (lbl, ptype) <- prec ] -unifyPType (Arg nr _ path) (ConT terms) = - do (_, args, _, _) <- readState - case lookup path (ecatConstraints (args !! nr)) of - Just term -> return term - Nothing -> do term <- member terms - updateArg nr (path, term) - return term - ------------------------------------------------------------- --- unification of patterns and selection terms - -(=?=) :: STerm -> STerm -> CnvMonad () --- Wildcard =?= _ = return () --- Var x =?= term = addBinding x term -Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | - (lbl, pat) <- precord ] -pat =?= Arg nr _ path = updateArg nr (path, pat) -(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms) - sequence_ $ zipWith (=?=) pats terms -Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm | - (lbl, pat) <- precord, - let mterm = lookup lbl record ] --- variants are not allowed in patterns, but in selection terms: -term =?= Variants terms = member terms >>= (term =?=) -pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term - ----------------------------------------------------------------------- --- variable bindings (does not work correctly) -{- -addBinding x term = do (a, b, c, d, bindings) <- readState - writeState (a, b, c, d, (x,term):bindings) - -readBinding x = do (_, _, _, _, bindings) <- readState - return $ maybe (Var x) id $ lookup x bindings --} - ------------------------------------------------------------- --- updating the MCF rule - -readArgCTypes :: CnvMonad [SLinType] -readArgCTypes = do (_, _, _, env) <- readState - return env - -updateArg :: Int -> Constraint -> CnvMonad () -updateArg arg cn - = do (head, args, lins, env) <- readState - args' <- updateNthM (addToECat cn) arg args - writeState (head, args', lins, env) - -updateHead :: Constraint -> CnvMonad () -updateHead cn - = do (head, args, lins, env) <- readState - head' <- addToECat cn head - writeState (head', args, lins, env) - -updateLin :: Constraint -> CnvMonad () -updateLin (path, term) - = do let newLins = term2lins term - (head, args, lins, env) <- readState - let lins' = lins ++ map (Lin path) newLins - writeState (head, args, lins', env) - -term2lins :: STerm -> [[Symbol (SCat, SPath, Int) Token]] -term2lins (Arg nr cat path) = return [Cat (cat, path, nr)] -term2lins (Token str) = return [Tok str] -term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2) -term2lins (Empty) = return [] -term2lins (Variants terms) = terms >>= term2lins -term2lins term = error $ "term2lins: " ++ show term - -addToECat :: Constraint -> ECat -> CnvMonad ECat -addToECat cn (ECat cat cns) = liftM (ECat cat) $ addConstraint cn cns - -addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] -addConstraint cn0 (cn : cns) - | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) - | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> - return (cn : cns) -addConstraint cn0 cns = return (cn0 : cns) - - - diff --git a/src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs b/src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs deleted file mode 100644 index a5519fcd8..000000000 --- a/src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs +++ /dev/null @@ -1,129 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- Converting SimpleGFC grammars to MCFG grammars, deterministic. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. ------------------------------------------------------------------------------ - - -module GF.Conversion.SimpleToMCFG.Strict - (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import Control.Monad - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.SimpleGFC -import GF.Conversion.Types - -import GF.Data.BacktrackM -import GF.Data.SortedList - ----------------------------------------------------------------------- --- main conversion function - -type CnvMonad a = BacktrackM () a - -convertGrammar :: SGrammar -> EGrammar -convertGrammar rules = tracePrt "SimpleToMCFG.Strict - MCFG rules" (prt . length) $ - solutions conversion undefined - where conversion = member rules >>= convertRule - -convertRule :: SRule -> CnvMonad ERule -convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) - = do let cat : args = map decl2cat (decl : decls) - args_ctypes = zip3 [0..] args ctypes - instArgs <- mapM enumerateArg args_ctypes - let instTerm = substitutePaths instArgs term - newCat <- extractECat cat ctype instTerm - newArgs <- mapM (extractArg instArgs) args_ctypes - let linRec = strPaths ctype instTerm >>= extractLin newArgs - let newLinRec = map (instantiateArgs newArgs) linRec - catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes) - return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) -convertRule _ = failure - ----------------------------------------------------------------------- --- category extraction - -extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad ECat -extractArg args (nr, cat, ctype) = extractECat cat ctype (args !! nr) - -extractECat :: SCat -> SLinType -> STerm -> CnvMonad ECat -extractECat cat ctype term = member $ map (ECat cat) $ parPaths ctype term - -enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm -enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype - ----------------------------------------------------------------------- --- Substitute each instantiated parameter path for its instantiation - -substitutePaths :: [STerm] -> STerm -> STerm -substitutePaths arguments = subst - where subst (Arg nr _ path) = termFollowPath path (arguments !! nr) - subst (con :^ terms) = con :^ map subst terms - subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ] - subst (term :. lbl) = subst term +. lbl - subst (Tbl table) = Tbl [ (pat, subst term) | - (pat, term) <- table ] - subst (term :! select) = subst term +! subst select - subst (term :++ term') = subst term ?++ subst term' - subst (Variants terms) = Variants $ map subst terms - subst term = term - ----------------------------------------------------------------------- --- term paths extaction - -termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))] -termPaths ctype (Variants terms) = terms >>= termPaths ctype -termPaths (RecT rtype) (Rec record) - = [ (path ++. lbl, value) | - (lbl, term) <- record, - let Just ctype = lookup lbl rtype, - (path, value) <- termPaths ctype term ] -termPaths (TblT _ ctype) (Tbl table) - = [ (path ++! pat, value) | - (pat, term) <- table, - (path, value) <- termPaths ctype term ] -termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ] - -{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): -{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} -[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] --} - -parPaths :: SLinType -> STerm -> [[(SPath, STerm)]] -parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ - nubsort [ (path, value) | - (path, (ConT _, value)) <- termPaths ctype term ] - -strPaths :: SLinType -> STerm -> [(SPath, STerm)] -strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ] - ----------------------------------------------------------------------- --- linearization extraction - -extractLin :: [ECat] -> (SPath, STerm) -> [Lin ECat MLabel Token] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (Empty) = [[]] - convertLin (Token tok) = [[Tok tok]] - convertLin (Variants terms) = concatMap convertLin terms - convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]] - convertLin t = error $ "convertLin: " ++ prt t ++ " " ++ prt (args, path) - diff --git a/src-3.0/GF/Conversion/TypeGraph.hs b/src-3.0/GF/Conversion/TypeGraph.hs deleted file mode 100644 index 62ee9726e..000000000 --- a/src-3.0/GF/Conversion/TypeGraph.hs +++ /dev/null @@ -1,58 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/16 10:21:21 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Printing the type hierarchy of an abstract module in GraphViz format ------------------------------------------------------------------------------ - - -module GF.Conversion.TypeGraph (prtTypeGraph, prtFunctionGraph) where - -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Formalism.Utilities -import GF.Conversion.Types - -import GF.Data.Operations ((++++), (+++++)) -import GF.Infra.Print - ----------------------------------------------------------------------- --- | SimpleGFC to TypeGraph --- --- assumes that the profiles in the Simple GFC names are trivial - -prtTypeGraph :: SGrammar -> String -prtTypeGraph rules = "digraph TypeGraph {" ++++ - "concentrate=true;" ++++ - "node [shape=ellipse];" +++++ - unlines (map prtTypeGraphRule rules) +++++ - "}" - -prtTypeGraphRule :: SRule -> String -prtTypeGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _) - = "// " ++ prt abs ++++ - unlines [ prtSCat c ++ " -> " ++ prtSCat cat ++ ";" | c <- cats ] - -prtFunctionGraph :: SGrammar -> String -prtFunctionGraph rules = "digraph FunctionGraph {" ++++ - "node [shape=ellipse];" +++++ - unlines (map prtFunctionGraphRule rules) +++++ - "}" - -prtFunctionGraphRule :: SRule -> String -prtFunctionGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _) - = "// " ++ prt abs ++++ - pfun ++ " [label=\"" ++ prt fun ++ "\", shape=box, style=dashed];" ++++ - pfun ++ " -> " ++ prtSCat cat ++ ";" ++++ - unlines [ prtSCat c ++ " -> " ++ pfun ++ ";" | c <- cats ] - where pfun = "GF_FUNCTION_" ++ prt fun - -prtSCat decl = prt (decl2cat decl) - - diff --git a/src-3.0/GF/Conversion/Types.hs b/src-3.0/GF/Conversion/Types.hs deleted file mode 100644 index 3fdb3c5e4..000000000 --- a/src-3.0/GF/Conversion/Types.hs +++ /dev/null @@ -1,146 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/11 14:11:46 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.10 $ --- --- All possible instantiations of different grammar formats used in conversion from GFC ------------------------------------------------------------------------------ - - -module GF.Conversion.Types where - ----import GF.Conversion.FTypes - -import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent) -import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..)) -import qualified GF.GFCC.CId -import qualified GF.Grammar.Grammar as Grammar (Term) - -import GF.Formalism.GCFG -import GF.Formalism.SimpleGFC -import GF.Formalism.MCFG -import GF.Formalism.FCFG -import GF.Formalism.CFG -import GF.Formalism.Utilities -import GF.Infra.Print -import GF.Data.Assoc - -import Control.Monad (foldM) -import Data.Array - ----------------------------------------------------------------------- --- * basic (leaf) types - --- ** input tokens - -type Token = String - --- ** function names - -type Fun = Ident.Ident -type Name = NameProfile Fun - - ----------------------------------------------------------------------- --- * Simple GFC - -type SCat = Ident.Ident - -constr2fun :: Constr -> Fun -constr2fun (AbsGFC.CIQ _ fun) = fun - --- ** grammar types - -type SGrammar = SimpleGrammar SCat Name Token -type SRule = SimpleRule SCat Name Token - -type SPath = Path SCat Token -type STerm = Term SCat Token -type SLinType = LinType SCat Token -type SDecl = Decl SCat - ----------------------------------------------------------------------- --- * erasing MCFG - -type EGrammar = MCFGrammar ECat Name ELabel Token -type ERule = MCFRule ECat Name ELabel Token -data ECat = ECat SCat [Constraint] deriving (Eq, Ord, Show) -type ELabel = SPath - -type Constraint = (SPath, STerm) - --- ** type coercions etc - -initialECat :: SCat -> ECat -initialECat cat = ECat cat [] - -ecat2scat :: ECat -> SCat -ecat2scat (ECat cat _) = cat - -ecatConstraints :: ECat -> [Constraint] -ecatConstraints (ECat _ cns) = cns - -sameECat :: ECat -> ECat -> Bool -sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2 - -coercionName :: Name -coercionName = Name Ident.identW [Unify [0]] - -isCoercion :: Name -> Bool -isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun -isCoercion _ = False - ----------------------------------------------------------------------- --- * nonerasing MCFG - -type MGrammar = MCFGrammar MCat Name MLabel Token -type MRule = MCFRule MCat Name MLabel Token -data MCat = MCat ECat [ELabel] deriving (Eq, Ord, Show) -type MLabel = ELabel - -mcat2ecat :: MCat -> ECat -mcat2ecat (MCat cat _) = cat - -mcat2scat :: MCat -> SCat -mcat2scat = ecat2scat . mcat2ecat - ----------------------------------------------------------------------- --- * fast nonerasing MCFG - ----- moved to FTypes by AR 20/9/2007 - - ----------------------------------------------------------------------- --- * CFG - -type CGrammar = CFGrammar CCat Name Token -type CRule = CFRule CCat Name Token -data CCat = CCat ECat ELabel deriving (Eq, Ord, Show) - -ccat2ecat :: CCat -> ECat -ccat2ecat (CCat cat _) = cat - -ccat2scat :: CCat -> SCat -ccat2scat = ecat2scat . ccat2ecat - ----------------------------------------------------------------------- --- * pretty-printing - -instance Print ECat where - prt (ECat cat constrs) = prt cat ++ "{" ++ - concat [ prt path ++ "=" ++ prt term ++ ";" | - (path, term) <- constrs ] ++ "}" - -instance Print MCat where - prt (MCat cat labels) = prt cat ++ prt labels - -instance Print CCat where - prt (CCat cat label) = prt cat ++ prt label - ----- instance Print FCat where ---- FCat - diff --git a/src-3.0/GF/Data/Compos.hs b/src-3.0/GF/Data/Compos.hs deleted file mode 100644 index 7d46fc5a2..000000000 --- a/src-3.0/GF/Data/Compos.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -module GF.Data.Compos (Compos(..),composOp,composM,composM_,composFold) where - -import Control.Applicative (Applicative(..), Const(..), WrappedMonad(..)) -import Data.Monoid (Monoid(..)) - -class Compos t where - compos :: Applicative f => (forall a. t a -> f (t a)) -> t c -> f (t c) - -composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c -composOp f = runIdentity . compos (Identity . f) - -composFold :: (Monoid o, Compos t) => (forall a. t a -> o) -> t c -> o -composFold f = getConst . compos (Const . f) - -composM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c) -composM f = unwrapMonad . compos (WrapMonad . f) - -composM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m () -composM_ f = unwrapMonad_ . composFold (WrapMonad_ . f) - - -newtype Identity a = Identity { runIdentity :: a } - -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) - - -newtype WrappedMonad_ m = WrapMonad_ { unwrapMonad_ :: m () } - -instance Monad m => Monoid (WrappedMonad_ m) where - mempty = WrapMonad_ (return ()) - WrapMonad_ x `mappend` WrapMonad_ y = WrapMonad_ (x >> y) diff --git a/src-3.0/GF/Data/Glue.hs b/src-3.0/GF/Data/Glue.hs deleted file mode 100644 index 4f276222b..000000000 --- a/src-3.0/GF/Data/Glue.hs +++ /dev/null @@ -1,30 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Glue --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:02 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@ ------------------------------------------------------------------------------ - -module GF.Data.Glue (decomposeSimple) where - -import GF.Data.Trie2 -import GF.Data.Operations -import Data.List - -decomposeSimple :: Trie Char a -> [Char] -> Err [[Char]] -decomposeSimple t s = do - let ss = map (decompose t) $ words s - if any null ss - then Bad "unknown word in input" - else return $ concat [intersperse "&+" ws | ws <- ss] - -exTrie = tcompile (zip ws ws) where - ws = words "ett tv\229 tre tjugo trettio hundra tusen" - diff --git a/src-3.0/GF/Data/IncrementalDeduction.hs b/src-3.0/GF/Data/IncrementalDeduction.hs deleted file mode 100644 index d119610c1..000000000 --- a/src-3.0/GF/Data/IncrementalDeduction.hs +++ /dev/null @@ -1,67 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Implementation of /incremental/ deductive parsing, --- i.e. parsing one word at the time. ------------------------------------------------------------------------------ - -module GF.Data.IncrementalDeduction - (-- * Type definitions - IncrementalChart, - -- * Functions - chartLookup, - buildChart, - chartList, chartKeys - ) where - -import Data.Array -import GF.Data.SortedList -import GF.Data.Assoc - ----------------------------------------------------------------------- --- main functions - -chartLookup :: (Ord item, Ord key) => - IncrementalChart item key - -> Int -> key -> SList item - -buildChart :: (Ord item, Ord key) => - (item -> key) -- ^ key lookup function - -> (Int -> item -> SList item) -- ^ all inference rules for position k, collected - -> (Int -> SList item) -- ^ all axioms for position k, collected - -> (Int, Int) -- ^ input bounds - -> IncrementalChart item key - -chartList :: (Ord item, Ord key) => - IncrementalChart item key -- ^ the final chart - -> (Int -> item -> edge) -- ^ function building an edge from - -- the position and the item - -> [edge] - -chartKeys :: (Ord item, Ord key) => IncrementalChart item key -> Int -> [key] - -type IncrementalChart item key = Array Int (Assoc key (SList item)) - ----------- - -chartLookup chart k key = (chart ! k) ? key - -buildChart keyof rules axioms bounds = finalChartArray - where buildState k = limit (rules k) $ axioms k - finalChartList = map buildState [fst bounds .. snd bounds] - finalChartArray = listArray bounds $ map stateAssoc finalChartList - stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ] - -chartList chart combine = [ combine k item | - (k, state) <- assocs chart, - item <- concatMap snd $ aAssocs state ] - -chartKeys chart k = aElems (chart ! k) - diff --git a/src-3.0/GF/Data/Map.hs b/src-3.0/GF/Data/Map.hs deleted file mode 100644 index c86c9ab55..000000000 --- a/src-3.0/GF/Data/Map.hs +++ /dev/null @@ -1,61 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Map --- Maintainer : Markus Forsberg --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Map ( - Map, - empty, - isEmpty, - (!), - (!+), - (|->), - (|->+), - (<+>), - flatten - ) where - -import GF.Data.RedBlack - -type Map key el = Tree key el - -infixl 6 |-> -infixl 6 |->+ -infixl 5 ! -infixl 5 !+ -infixl 4 <+> - -empty :: Map key el -empty = emptyTree - --- | lookup operator. -(!) :: Ord key => Map key el -> key -> Maybe el -(!) fm e = lookupTree e fm - --- | lookupMany operator. -(!+) :: Ord key => Map key el -> [key] -> [Maybe el] -fm !+ [] = [] -fm !+ (e:es) = (lookupTree e fm): (fm !+ es) - --- | insert operator. -(|->) :: Ord key => (key,el) -> Map key el -> Map key el -(x,y) |-> fm = insertTree (x,y) fm - --- | insertMany operator. -(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el -[] |->+ fm = fm -((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm) - --- | union operator. -(<+>) :: Ord key => Map key el -> Map key el -> Map key el -(<+>) fm1 fm2 = xs |->+ fm2 - where xs = flatten fm1 diff --git a/src-3.0/GF/Data/OrdMap2.hs b/src-3.0/GF/Data/OrdMap2.hs deleted file mode 100644 index 3590f0584..000000000 --- a/src-3.0/GF/Data/OrdMap2.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OrdMap2 --- Maintainer : Peter Ljunglöf --- Stability : Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- The class of finite maps, as described in --- \"Pure Functional Parsing\", section 2.2.2 --- and an example implementation, --- derived from appendix A.2 --- --- /OBSOLETE/! this is only used in module "ChartParser" ------------------------------------------------------------------------------ - -module GF.Data.OrdMap2 (OrdMap(..), Map) where - -import Data.List (intersperse) - - --------------------------------------------------- --- the class of ordered finite maps - -class OrdMap m where - emptyMap :: Ord s => m s a - (|->) :: Ord s => s -> a -> m s a - isEmptyMap :: Ord s => m s a -> Bool - (?) :: Ord s => m s a -> s -> Maybe a - lookupWith :: Ord s => a -> m s a -> s -> a - mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a - unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a - makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a - assocs :: Ord s => m s a -> [(s,a)] - ordMap :: Ord s => [(s,a)] -> m s a - mapMap :: Ord s => (a -> b) -> m s a -> m s b - - lookupWith z m s = case m ? s of - Just a -> a - Nothing -> z - - unionMapWith join = union - where union [] = emptyMap - union [xs] = xs - union xyss = mergeWith join (union xss) (union yss) - where (xss, yss) = split xyss - split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) - split xs = (xs, []) - - --------------------------------------------------- --- finite maps as ordered associaiton lists, --- paired with binary search trees - -data Map s a = Map [(s,a)] (TreeMap s a) - -instance (Eq s, Eq a) => Eq (Map s a) where - Map xs _ == Map ys _ = xs == ys - -instance (Show s, Show a) => Show (Map s a) where - show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}" - where show' (s,a) = show s ++ "|->" ++ show a - -instance OrdMap Map where - emptyMap = Map [] (makeTree []) - s |-> a = Map [(s,a)] (makeTree [(s,a)]) - - isEmptyMap (Map ass _) = null ass - - Map _ tree ? s = lookupTree s tree - - mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss) - where xyss = merge xss yss - merge [] yss = yss - merge xss [] = xss - merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss') - = case compare s t of - LT -> x : merge xss' yss - GT -> y : merge xss yss' - EQ -> (s, join x' y') : merge xss' yss' - - makeMapWith join [] = emptyMap - makeMapWith join [(s,a)] = s |-> a - makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss) - where (xss, yss) = split xyss - split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys) - split xs = (xs, []) - - assocs (Map xss _) = xss - ordMap xss = Map xss (makeTree xss) - - mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree) - - --------------------------------------------------- --- binary search trees --- for logarithmic lookup time - -data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a) - -makeTree ass = tree - where - (tree,[]) = sl2bst (length ass) ass - sl2bst 0 ass = (Nil, ass) - sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass) - sl2bst n ass = (Node ltree s a rtree, css) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (ltree, (s,a):bss) = sl2bst llen ass - (rtree, css) = sl2bst rlen bss - -lookupTree s Nil = Nothing -lookupTree s (Node left s' a right) - = case compare s s' of - LT -> lookupTree s left - GT -> lookupTree s right - EQ -> Just a - -mapTree f Nil = Nil -mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right) - - - - diff --git a/src-3.0/GF/Data/OrdSet.hs b/src-3.0/GF/Data/OrdSet.hs deleted file mode 100644 index 34eb0705d..000000000 --- a/src-3.0/GF/Data/OrdSet.hs +++ /dev/null @@ -1,120 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OrdSet --- Maintainer : Peter Ljunglöf --- Stability : Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:06 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- The class of ordered sets, as described in --- \"Pure Functional Parsing\", section 2.2.1, --- and an example implementation --- derived from appendix A.1 --- --- /OBSOLETE/! this is only used in module "ChartParser" ------------------------------------------------------------------------------ - -module GF.Data.OrdSet (OrdSet(..), Set) where - -import Data.List (intersperse) - - --------------------------------------------------- --- the class of ordered sets - -class OrdSet m where - emptySet :: Ord a => m a - unitSet :: Ord a => a -> m a - isEmpty :: Ord a => m a -> Bool - elemSet :: Ord a => a -> m a -> Bool - (<++>) :: Ord a => m a -> m a -> m a - (<\\>) :: Ord a => m a -> m a -> m a - plusMinus :: Ord a => m a -> m a -> (m a, m a) - union :: Ord a => [m a] -> m a - makeSet :: Ord a => [a] -> m a - elems :: Ord a => m a -> [a] - ordSet :: Ord a => [a] -> m a - limit :: Ord a => (a -> m a) -> m a -> m a - - xs <++> ys = fst (plusMinus xs ys) - xs <\\> ys = snd (plusMinus xs ys) - plusMinus xs ys = (xs <++> ys, xs <\\> ys) - - union [] = emptySet - union [xs] = xs - union xyss = union xss <++> union yss - where (xss, yss) = split xyss - split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) - split xs = (xs, []) - - makeSet xs = union (map unitSet xs) - - limit more start = limit' (start, start) - where limit' (old, new) - | isEmpty new' = old - | otherwise = limit' (plusMinus new' old) - where new' = union (map more (elems new)) - - --------------------------------------------------- --- sets as ordered lists, --- paired with a binary tree - -data Set a = Set [a] (TreeSet a) - -instance Eq a => Eq (Set a) where - Set xs _ == Set ys _ = xs == ys - -instance Ord a => Ord (Set a) where - compare (Set xs _) (Set ys _) = compare xs ys - -instance Show a => Show (Set a) where - show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}" - -instance OrdSet Set where - emptySet = Set [] (makeTree []) - unitSet a = Set [a] (makeTree [a]) - - isEmpty (Set xs _) = null xs - elemSet a (Set _ xt) = elemTree a xt - - plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms)) - where (ps, ms) = plm xs ys - plm [] ys = (ys, []) - plm xs [] = (xs, xs) - plm xs@(x:xs') ys@(y:ys') = case compare x y of - LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms) - GT -> let (ps, ms) = plm xs ys' in (y:ps, ms) - EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms) - - elems (Set xs _) = xs - ordSet xs = Set xs (makeTree xs) - - --------------------------------------------------- --- binary search trees --- for logarithmic lookup time - -data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a) - -makeTree xs = tree - where (tree,[]) = sl2bst (length xs) xs - sl2bst 0 xs = (Nil, xs) - sl2bst 1 (a:xs) = (Node Nil a Nil, xs) - sl2bst n xs = (Node ltree a rtree, zs) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (ltree, a:ys) = sl2bst llen xs - (rtree, zs) = sl2bst rlen ys - -elemTree a Nil = False -elemTree a (Node ltree x rtree) - = case compare a x of - LT -> elemTree a ltree - GT -> elemTree a rtree - EQ -> True - - diff --git a/src-3.0/GF/Data/Parsers.hs b/src-3.0/GF/Data/Parsers.hs deleted file mode 100644 index f9bf02598..000000000 --- a/src-3.0/GF/Data/Parsers.hs +++ /dev/null @@ -1,196 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Parsers --- Maintainer : Aarne Ranta --- Stability : Almost Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:06 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- some parser combinators a la Wadler and Hutton. --- no longer used in many places in GF --- (only used in module "EBNF") ------------------------------------------------------------------------------ - -module GF.Data.Parsers (-- * Main types and functions - Parser, parseResults, parseResultErr, - -- * Basic combinators (on any token type) - (...), (.>.), (|||), (+||), literal, (***), - succeed, fails, (+..), (..+), (<<<), (|>), - many, some, longestOfMany, longestOfSome, - closure, - -- * Specific combinators (for @Char@ token type) - pJunk, pJ, jL, pTList, pTJList, pElem, - (....), item, satisfy, literals, lits, - pParenth, pCommaList, pOptCommaList, - pArgList, pArgList2, - pIdent, pLetter, pDigit, pLetters, - pAlphanum, pAlphaPlusChar, - pQuotedString, pIntc - ) where - -import GF.Data.Operations -import Data.Char -import Data.List - - -infixr 2 |||, +|| -infixr 3 *** -infixr 5 .>. -infixr 5 ... -infixr 5 .... -infixr 5 +.. -infixr 5 ..+ -infixr 6 |> -infixr 3 <<< - - -type Parser a b = [a] -> [(b,[a])] - -parseResults :: Parser a b -> [a] -> [b] -parseResults p s = [x | (x,r) <- p s, null r] - -parseResultErr :: Show a => Parser a b -> [a] -> Err b -parseResultErr p s = case parseResults p s of - [x] -> return x - [] -> case - maximumBy (\x y -> compare (length y) (length x)) (s:[r | (_,r) <- p s]) of - r -> Bad $ "\nno parse; reached" ++++ take 300 (show r) - _ -> Bad "ambiguous" - -(...) :: Parser a b -> Parser a c -> Parser a (b,c) -(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] - -(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c -(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t] - -(|||) :: Parser a b -> Parser a b -> Parser a b -(p ||| q) s = p s ++ q s - -(+||) :: Parser a b -> Parser a b -> Parser a b -p1 +|| p2 = take 1 . (p1 ||| p2) - -literal :: (Eq a) => a -> Parser a a -literal x (c:cs) = [(x,cs) | x == c] -literal _ _ = [] - -(***) :: Parser a b -> (b -> c) -> Parser a c -(p *** f) s = [(f x,r) | (x,r) <- p s] - -succeed :: b -> Parser a b -succeed v s = [(v,s)] - -fails :: Parser a b -fails s = [] - -(+..) :: Parser a b -> Parser a c -> Parser a c -p1 +.. p2 = p1 ... p2 *** snd - -(..+) :: Parser a b -> Parser a c -> Parser a b -p1 ..+ p2 = p1 ... p2 *** fst - -(<<<) :: Parser a b -> c -> Parser a c -- return -p <<< v = p *** (\x -> v) - -(|>) :: Parser a b -> (b -> Bool) -> Parser a b -p |> b = p .>. (\x -> if b x then succeed x else fails) - -many :: Parser a b -> Parser a [b] -many p = (p ... many p *** uncurry (:)) +|| succeed [] - -some :: Parser a b -> Parser a [b] -some p = (p ... many p) *** uncurry (:) - -longestOfMany :: Parser a b -> Parser a [b] -longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed [] - -closure :: (b -> Parser a b) -> (b -> Parser a b) -closure p v = p v .>. closure p ||| succeed v - -pJunk :: Parser Char String -pJunk = longestOfMany (satisfy (\x -> elem x "\n\t ")) - -pJ :: Parser Char a -> Parser Char a -pJ p = pJunk +.. p ..+ pJunk - -pTList :: String -> Parser Char a -> Parser Char [a] -pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999 - -pTJList :: String -> String -> Parser Char a -> Parser Char [a] -pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:)) - -pElem :: [String] -> Parser Char String -pElem l = foldr (+||) fails (map literals l) - -(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c) -p1 .... p2 = p1 ... pJunk +.. p2 - -item :: Parser a a -item (c:cs) = [(c,cs)] -item [] = [] - -satisfy :: (a -> Bool) -> Parser a a -satisfy b = item |> b - -literals :: (Eq a,Show a) => [a] -> Parser a [a] -literals l = case l of - [] -> succeed [] - a:l -> literal a ... literals l *** (\ (x,y) -> x:y) - -lits :: (Eq a,Show a) => [a] -> Parser a [a] -lits ts = literals ts - -jL :: String -> Parser Char String -jL = pJ . lits - -pParenth :: Parser Char a -> Parser Char a -pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')' - --- | p,...,p -pCommaList :: Parser Char a -> Parser Char [a] -pCommaList p = pTList "," (pJ p) - --- | the same or nothing -pOptCommaList :: Parser Char a -> Parser Char [a] -pOptCommaList p = pCommaList p ||| succeed [] - --- | (p,...,p), poss. empty -pArgList :: Parser Char a -> Parser Char [a] -pArgList p = pParenth (pCommaList p) ||| succeed [] - --- | min. 2 args -pArgList2 :: Parser Char a -> Parser Char [a] -pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) - -longestOfSome :: Parser a b -> Parser a [b] -longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y) - -pIdent :: Parser Char String -pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:) - where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\'' - -pLetter, pDigit :: Parser Char Char -pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ - ['\192' .. '\255'])) -- no such in Char -pDigit = satisfy isDigit - -pLetters :: Parser Char String -pLetters = longestOfSome pLetter - -pAlphanum, pAlphaPlusChar :: Parser Char Char -pAlphanum = pDigit ||| pLetter -pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'") - -pQuotedString :: Parser Char String -pQuotedString = literal '"' +.. pEndQuoted where - pEndQuoted = - literal '"' *** (const []) - +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:)) - +|| item .>. \ c -> pEndQuoted *** (c:) - -pIntc :: Parser Char Int -pIntc = some (satisfy numb) *** read - where numb x = elem x ['0'..'9'] - diff --git a/src-3.0/GF/Data/RedBlack.hs b/src-3.0/GF/Data/RedBlack.hs deleted file mode 100644 index fd70dba63..000000000 --- a/src-3.0/GF/Data/RedBlack.hs +++ /dev/null @@ -1,64 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : RedBlack --- Maintainer : Markus Forsberg --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Modified version of Osanaki's implementation. ------------------------------------------------------------------------------ - -module GF.Data.RedBlack ( - emptyTree, - isEmpty, - Tree, - lookupTree, - insertTree, - flatten - ) where - -data Color = R | B - deriving (Show,Read) - -data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el) - deriving (Show,Read) - -balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b -balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) -balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) -balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) -balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) -balance color a x b = T color a x b - -emptyTree :: Tree key el -emptyTree = E - -isEmpty :: Tree key el -> Bool -isEmpty (E) = True -isEmpty _ = False - -lookupTree :: Ord a => a -> Tree a b -> Maybe b -lookupTree _ E = Nothing -lookupTree x (T _ a (y,z) b) - | x < y = lookupTree x a - | x > y = lookupTree x b - | otherwise = return z - -insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b -insertTree (key,el) tree = T B a y b - where - T _ a y b = ins tree - ins E = T R E (key,el) E - ins (T color a y@(key',el') b) - | key < key' = balance color (ins a) y b - | key > key' = balance color a y (ins b) - | otherwise = T color a (key',el) b - -flatten :: Tree a b -> [(a,b)] -flatten E = [] -flatten (T _ left (key,e) right) - = (flatten left) ++ ((key,e):(flatten right)) diff --git a/src-3.0/GF/Data/SharedString.hs b/src-3.0/GF/Data/SharedString.hs deleted file mode 100644 index 9d037b512..000000000 --- a/src-3.0/GF/Data/SharedString.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module GF.Data.SharedString (shareString) where - -import Data.HashTable as H -import System.IO.Unsafe (unsafePerformIO) - -{-# NOINLINE stringPool #-} -stringPool :: HashTable String String -stringPool = unsafePerformIO $ new (==) hashString - -{-# NOINLINE shareString #-} -shareString :: String -> String -shareString s = unsafePerformIO $ do - mv <- H.lookup stringPool s - case mv of - Just s' -> return s' - Nothing -> do - H.insert stringPool s s - return s diff --git a/src-3.0/GF/Data/Trie.hs b/src-3.0/GF/Data/Trie.hs deleted file mode 100644 index 9fb5daa27..000000000 --- a/src-3.0/GF/Data/Trie.hs +++ /dev/null @@ -1,129 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Trie --- Maintainer : Markus Forsberg --- Stability : Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Trie ( - tcompile, - collapse, - Trie, - trieLookup, - decompose, - Attr, - atW, atP, atWP - ) where - -import GF.Data.Map - ---- data Attr = W | P | WP deriving Eq -type Attr = Int - -atW, atP, atWP :: Attr -(atW,atP,atWP) = (0,1,2) - -newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)]) - -newtype Trie = Trie (Map Char Trie, [(Attr,String)]) - -emptyTrie = TrieT ([],[]) - -optimize :: TrieT -> Trie -optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, - res) - -collapse :: Trie -> [(String,[(Attr,String)])] -collapse trie = collapse' trie [] - where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))] - else (reverse s,(x:xs)): - concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - collapse' (Trie (map,[])) s - = concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - -tcompile :: [(String,[(Attr,String)])] -> Trie -tcompile xs = optimize $ build xs emptyTrie - -build :: [(String,[(Attr,String)])] -> TrieT -> TrieT -build [] trie = trie -build (x:xs) trie = build xs (insert x trie) - where - insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) - insert ((s:ss),ys) (TrieT (xs,res)) - = case (span (\(s',_) -> s' /= s) xs) of - (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res) - (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) - -trieLookup :: Trie -> String -> (String,[(Attr,String)]) -trieLookup trie s = apply trie s s - -apply :: Trie -> String -> String -> (String,[(Attr,String)]) -apply (Trie (_,res)) [] inp = (inp,res) -apply (Trie (map,_)) (s:ss) inp - = case map ! s of - Just trie -> apply trie ss inp - Nothing -> (inp,[]) - --- Composite analysis (Huet's unglue algorithm) --- only legaldecompositions are accepted. --- With legal means that the composite forms are ordered correctly --- with respect to the attributes W,P and WP. - --- Composite analysis - -testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])] - -decompose :: Trie -> String -> [String] -decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie - --- The function legal checks if the decomposition is in fact a possible one. - -legal :: Trie -> [String] -> [String] -legal _ [] = [] -legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] - where - test [] = False - test [xs] = elem atW xs || elem atWP xs - test (xs:xss) = (elem atP xs || elem atWP xs) && test xss - -react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] -react input output back occ (Trie (arcs,res)) init = - case res of -- Accept = non-empty res. - [] -> continue back - _ -> let pushout = (occ:output) - in case input of - [] -> reverse $ map reverse pushout - _ -> let pushback = ((input,pushout):back) - in continue pushback - where continue cont = case input of - [] -> backtrack cont init - (l:rest) -> case arcs ! l of - Just trie -> - react rest output cont (l:occ) trie init - Nothing -> backtrack cont init - -backtrack :: [(String,[String])] -> Trie -> [String] -backtrack [] _ = [] -backtrack ((input,output):back) trie - = react input output back [] trie trie - -{- --- The function legal checks if the decomposition is in fact a possible one. -legal :: Trie -> [String] -> [String] -legal _ [] = [] -legal trie input - | test $ - map ((map fst).snd.(trieLookup trie)) input = input - | otherwise = [] - where -- test checks that the Attrs are in the correct order. - test [] = False -- This case should never happen. - test [xs] = elem W xs || elem WP xs - test (xs:xss) = (elem P xs || elem WP xs) && test xss --} diff --git a/src-3.0/GF/Data/Trie2.hs b/src-3.0/GF/Data/Trie2.hs deleted file mode 100644 index 36fcc3221..000000000 --- a/src-3.0/GF/Data/Trie2.hs +++ /dev/null @@ -1,120 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Trie2 --- Maintainer : Markus Forsberg --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:10 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Trie2 ( - tcompile, - collapse, - Trie, - trieLookup, - decompose, - --- Attr, atW, atP, atWP, - emptyTrie - ) where - -import GF.Data.Map -import Data.List - -newtype TrieT a b = TrieT ([(a,TrieT a b)],[b]) - -newtype Trie a b = Trie (Map a (Trie a b), [b]) - -emptyTrieT = TrieT ([],[]) - -emptyTrie :: Trie a b -emptyTrie = Trie (empty,[]) - -optimize :: (Ord a,Eq b) => TrieT a b -> Trie a b -optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, - nub res) --- nub by AR - -collapse :: Ord a => Trie a b -> [([a],[b])] -collapse trie = collapse' trie [] - where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))] - else (reverse s,(x:xs)): - concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - collapse' (Trie (map,[])) s - = concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - -tcompile :: (Ord a,Eq b) => [([a],[b])] -> Trie a b -tcompile xs = optimize $ build xs emptyTrieT - -build :: Ord a => [([a],[b])] -> TrieT a b -> TrieT a b -build [] trie = trie -build (x:xs) trie = build xs (insert x trie) - where - insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) - insert ((s:ss),ys) (TrieT (xs,res)) - = case (span (\(s',_) -> s' /= s) xs) of - (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrieT)):xs),res) - (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) - -trieLookup :: Ord a => Trie a b -> [a] -> ([a],[b]) -trieLookup trie s = apply trie s s - -apply :: Ord a => Trie a b -> [a] -> [a] -> ([a],[b]) -apply (Trie (_,res)) [] inp = (inp,res) -apply (Trie (map,_)) (s:ss) inp - = case map ! s of - Just trie -> apply trie ss inp - Nothing -> (inp,[]) - ------------------------------ --- from Trie for strings; simplified for GF by making binding always possible (AR) - -decompose :: Ord a => Trie a b -> [a] -> [[a]] -decompose trie sentence = backtrack [(sentence,[])] trie - -react :: Ord a => [a] -> [[a]] -> [([a],[[a]])] -> - [a] -> Trie a b -> Trie a b -> [[a]] --- String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] -react input output back occ (Trie (arcs,res)) init = - case res of -- Accept = non-empty res. - [] -> continue back - _ -> let pushout = (occ:output) - in case input of - [] -> reverse $ map reverse pushout - _ -> let pushback = ((input,pushout):back) - in continue pushback - where continue cont = case input of - [] -> backtrack cont init - (l:rest) -> case arcs ! l of - Just trie -> - react rest output cont (l:occ) trie init - Nothing -> backtrack cont init - -backtrack :: Ord a => [([a],[[a]])] -> Trie a b -> [[a]] -backtrack [] _ = [] -backtrack ((input,output):back) trie - = react input output back [] trie trie - - -{- so this is not needed from the original -type Attr = Int - -atW, atP, atWP :: Attr -(atW,atP,atWP) = (0,1,2) - -decompose :: Ord a => Trie a (Int,b) -> [a] -> [[a]] -decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie - --- The function legal checks if the decomposition is in fact a possible one. - -legal :: Ord a => Trie a (Int,b) -> [[a]] -> [[a]] -legal _ [] = [] -legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] - where - test [] = False - test [xs] = elem atW xs || elem atWP xs - test (xs:xss) = (elem atP xs || elem atWP xs) && test xss --} diff --git a/src-3.0/GF/Data/XML.hs b/src-3.0/GF/Data/XML.hs deleted file mode 100644 index a1807adcc..000000000 --- a/src-3.0/GF/Data/XML.hs +++ /dev/null @@ -1,57 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : XML --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- Utilities for creating XML documents. ------------------------------------------------------------------------------ - -module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where - -import GF.Data.Utilities - -data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty - deriving (Ord,Eq,Show) - -type Attr = (String,String) - -comments :: [String] -> [XML] -comments = map Comment - -showXMLDoc :: XML -> String -showXMLDoc xml = showsXMLDoc xml "" - -showsXMLDoc :: XML -> ShowS -showsXMLDoc xml = showString header . showsXML xml - where header = "" - -showsXML :: XML -> ShowS -showsXML (Data s) = showString s -showsXML (CData s) = showString "" -showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>" -showsXML (Tag t as cs) = - showChar '<' . showString t . showsAttrs as . showChar '>' - . concatS (map showsXML cs) . showString "' -showsXML (Comment c) = showString "" -showsXML (Empty) = id - -showsAttrs :: [Attr] -> ShowS -showsAttrs = concatS . map (showChar ' ' .) . map showsAttr - -showsAttr :: Attr -> ShowS -showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\"" - -escape :: String -> String -escape = concatMap escChar - where - escChar '<' = "<" - escChar '>' = ">" - escChar '&' = "&" - escChar '"' = """ - escChar c = [c] - -bottomUpXML :: (XML -> XML) -> XML -> XML -bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs)) -bottomUpXML f x = f x diff --git a/src-3.0/GF/Devel/AbsCompute.hs b/src-3.0/GF/Devel/AbsCompute.hs deleted file mode 100644 index a55fbc83f..000000000 --- a/src-3.0/GF/Devel/AbsCompute.hs +++ /dev/null @@ -1,145 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AbsCompute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- computation in abstract syntax w.r.t. explicit definitions. --- --- old GF computation; to be updated ------------------------------------------------------------------------------ - -module GF.Devel.AbsCompute (LookDef, - compute, - computeAbsTerm, - computeAbsTermIn, - beta - ) where - -import GF.Data.Operations - -import GF.Grammar.Abstract -import GF.Grammar.PrGrammar -import GF.Grammar.LookAbs -import GF.Devel.Compute - -import Debug.Trace -import Data.List(intersperse) -import Control.Monad (liftM, liftM2) - --- for debugging -tracd m t = t --- tracd = trace - -compute :: GFCGrammar -> Exp -> Err Exp -compute = computeAbsTerm - -computeAbsTerm :: GFCGrammar -> Exp -> Err Exp -computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] - --- | a hack to make compute work on source grammar as well -type LookDef = Ident -> Ident -> Err (Maybe Term) - -computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp -computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where - compt vv t = case t of --- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) --- Abs x b -> liftM (Abs x) (compt (x:vv) b) - _ -> do - let t' = beta vv t - (yy,f,aa) <- termForm t' - let vv' = yy ++ vv - aa' <- mapM (compt vv') aa - case look f of - Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $ - case findMatch eqs aa' of - Ok (d,g) -> do - --- let (xs,ts) = unzip g - --- ts' <- alphaFreshAll vv' ts - let g' = g --- zip xs ts' - d' <- compt vv' $ substTerm vv' g' d - tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' - _ -> tracd ("no match" +++ prt t') $ - do - let v = mkApp f aa' - return $ mkAbs yy $ v - Just d -> tracd ("define" +++ prt t') $ do - da <- compt vv' $ mkApp d aa' - return $ mkAbs yy $ da - _ -> do - let t2 = mkAbs yy $ mkApp f aa' - tracd ("not defined" +++ prt_ t2) $ return t2 - - look t = case t of - (Q m f) -> case lookd m f of - Ok (Just EData) -> Nothing -- canonical --- should always be QC - Ok md -> md - _ -> Nothing - Eqs _ -> return t ---- for nested fn - _ -> Nothing - -beta :: [Ident] -> Exp -> Exp -beta vv c = case c of - Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) - App f a -> - let (a',f') = (beta vv a, beta vv f) in - case f' of - Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) - _ -> (if a'==a && f'==f then id else beta vv) $ App f' a' - Prod x a b -> Prod x (beta vv a) (beta (x:vv) b) - Abs x b -> Abs x (beta (x:vv) b) - _ -> c - --- special version of pattern matching, to deal with comp under lambda - -findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) -findMatch cases terms = case cases of - [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) - (patts,_):_ | length patts /= length terms -> - Bad ("wrong number of args for patterns :" +++ - unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs) - _ -> findMatch cc terms - -tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do - t' <- termForm t - trym p t' - where - - trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- - case (p,t') of - (PV IW, _) | notMeta t -> return [] -- optimization with wildcard - (PV x, _) | notMeta t -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PP q p pp, ([], QC r f, tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PP q p pp, ([], Q r f, tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PT _ p',_) -> trym p' t' - (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t) - - notMeta e = case e of - Meta _ -> False - App f a -> notMeta f && notMeta a - Abs _ b -> notMeta b - _ -> True - - prtm p g = - prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g] diff --git a/src-3.0/GF/Devel/CheckGrammar.hs b/src-3.0/GF/Devel/CheckGrammar.hs index a61e52d2a..3648b610a 100644 --- a/src-3.0/GF/Devel/CheckGrammar.hs +++ b/src-3.0/GF/Devel/CheckGrammar.hs @@ -256,7 +256,7 @@ checkCncInfo gr m (a,abs) (c,info) = do case info of CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do - typ <- checkErr $ lookupFunTypeSrc gr a c + typ <- checkErr $ lookupFunType gr a c cat0 <- checkErr $ valCat typ (cont,val) <- linTypeOfType gr m typ -- creates arg vars (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars @@ -266,7 +266,7 @@ checkCncInfo gr m (a,abs) (c,info) = do -- cat for cf, typ for pe CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do - checkErr $ lookupCatContextSrc gr a c + checkErr $ lookupCatContext gr a c typ' <- checkIfLinType gr typ mdef' <- case mdef of Yes def -> do diff --git a/src-3.0/GF/Devel/CheckM.hs b/src-3.0/GF/Devel/CheckM.hs deleted file mode 100644 index d26dbc07c..000000000 --- a/src-3.0/GF/Devel/CheckM.hs +++ /dev/null @@ -1,89 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckM --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Devel.CheckM (Check, - checkError, checkCond, checkWarn, checkUpdate, checkInContext, - checkUpdates, checkReset, checkResets, checkGetContext, - checkLookup, checkStart, checkErr, checkVal, checkIn, - prtFail - ) where - -import GF.Data.Operations -import GF.Devel.Grammar.Grammar -import GF.Infra.Ident -import GF.Devel.Grammar.PrGF - --- | the strings are non-fatal warnings -type Check a = STM (Context,[String]) a - -checkError :: String -> Check a -checkError = raise - -checkCond :: String -> Bool -> Check () -checkCond s b = if b then return () else checkError s - --- | warnings should be reversed in the end -checkWarn :: String -> Check () -checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg)) - -checkUpdate :: Decl -> Check () -checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg)) - -checkInContext :: [Decl] -> Check r -> Check r -checkInContext g ch = do - i <- checkUpdates g - r <- ch - checkResets i - return r - -checkUpdates :: [Decl] -> Check Int -checkUpdates ds = mapM checkUpdate ds >> return (length ds) - -checkReset :: Check () -checkReset = checkResets 1 - -checkResets :: Int -> Check () -checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg)) - -checkGetContext :: Check Context -checkGetContext = do - (co,_) <- readSTM - return co - -checkLookup :: Ident -> Check Type -checkLookup x = do - co <- checkGetContext - checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co - -checkStart :: Check a -> Err (a,(Context,[String])) -checkStart c = appSTM c ([],[]) - -checkErr :: Err a -> Check a -checkErr e = stm (\s -> do - v <- e - return (v,s) - ) - -checkVal :: a -> Check a -checkVal v = return v - -prtFail :: Print a => String -> a -> Check b -prtFail s t = checkErr $ prtBad s t - -checkIn :: String -> Check a -> Check a -checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of - Bad e -> Bad $ msg ++++ e - Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where - new = take (length ws' - length ws) ws' - ws2 = [msg ++++ w | w <- new] ++ ws diff --git a/src-3.0/GF/Devel/Compile/AbsGF.hs b/src-3.0/GF/Devel/Compile/AbsGF.hs deleted file mode 100644 index d053a3fa1..000000000 --- a/src-3.0/GF/Devel/Compile/AbsGF.hs +++ /dev/null @@ -1,274 +0,0 @@ -module GF.Devel.Compile.AbsGF where - --- Haskell module generated by the BNF converter - -newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show) -newtype LString = LString String deriving (Eq,Ord,Show) -data Grammar = - Gr [ModDef] - deriving (Eq,Ord,Show) - -data ModDef = - MModule ComplMod ModType ModBody - deriving (Eq,Ord,Show) - -data ModType = - MAbstract PIdent - | MResource PIdent - | MGrammar PIdent - | MInterface PIdent - | MConcrete PIdent PIdent - | MInstance PIdent PIdent - deriving (Eq,Ord,Show) - -data ModBody = - MBody Extend Opens [TopDef] - | MNoBody [Included] - | MWith Included [Open] - | MWithBody Included [Open] Opens [TopDef] - | MWithE [Included] Included [Open] - | MWithEBody [Included] Included [Open] Opens [TopDef] - | MReuse PIdent - | MUnion [Included] - deriving (Eq,Ord,Show) - -data Extend = - Ext [Included] - | NoExt - deriving (Eq,Ord,Show) - -data Opens = - NoOpens - | OpenIn [Open] - deriving (Eq,Ord,Show) - -data Open = - OName PIdent - | OQual PIdent PIdent - deriving (Eq,Ord,Show) - -data ComplMod = - CMCompl - | CMIncompl - deriving (Eq,Ord,Show) - -data Included = - IAll PIdent - | ISome PIdent [PIdent] - | IMinus PIdent [PIdent] - deriving (Eq,Ord,Show) - -data TopDef = - DefCat [CatDef] - | DefFun [FunDef] - | DefFunData [FunDef] - | DefDef [Def] - | DefData [DataDef] - | DefPar [ParDef] - | DefOper [Def] - | DefLincat [Def] - | DefLindef [Def] - | DefLin [Def] - | DefPrintCat [Def] - | DefPrintFun [Def] - | DefFlag [Def] - | DefPrintOld [Def] - | DefLintype [Def] - | DefPattern [Def] - | DefPackage PIdent [TopDef] - | DefVars [Def] - | DefTokenizer PIdent - deriving (Eq,Ord,Show) - -data Def = - DDecl [Name] Exp - | DDef [Name] Exp - | DPatt Name [Patt] Exp - | DFull [Name] Exp Exp - deriving (Eq,Ord,Show) - -data FunDef = - FDecl [Name] Exp - deriving (Eq,Ord,Show) - -data CatDef = - SimpleCatDef PIdent [DDecl] - | ListCatDef PIdent [DDecl] - | ListSizeCatDef PIdent [DDecl] Integer - deriving (Eq,Ord,Show) - -data DataDef = - DataDef Name [DataConstr] - deriving (Eq,Ord,Show) - -data DataConstr = - DataId PIdent - | DataQId PIdent PIdent - deriving (Eq,Ord,Show) - -data ParDef = - ParDefDir PIdent [ParConstr] - | ParDefAbs PIdent - deriving (Eq,Ord,Show) - -data ParConstr = - ParConstr PIdent [DDecl] - deriving (Eq,Ord,Show) - -data Name = - PIdentName PIdent - | ListName PIdent - deriving (Eq,Ord,Show) - -data LocDef = - LDDecl [PIdent] Exp - | LDDef [PIdent] Exp - | LDFull [PIdent] Exp Exp - deriving (Eq,Ord,Show) - -data Exp = - EPIdent PIdent - | EConstr PIdent - | ECons PIdent - | ESort Sort - | EString String - | EInt Integer - | EFloat Double - | EMeta - | EEmpty - | EData - | EList PIdent Exps - | EStrings String - | ERecord [LocDef] - | ETuple [TupleComp] - | EIndir PIdent - | ETyped Exp Exp - | EProj Exp Label - | EQConstr PIdent PIdent - | EQCons PIdent PIdent - | EApp Exp Exp - | ETable [Case] - | ETTable Exp [Case] - | EVTable Exp [Exp] - | ECase Exp [Case] - | EVariants [Exp] - | EPre Exp [Altern] - | EStrs [Exp] - | EPatt Patt - | EPattType Exp - | ESelect Exp Exp - | ETupTyp Exp Exp - | EExtend Exp Exp - | EGlue Exp Exp - | EConcat Exp Exp - | EAbstr [Bind] Exp - | ECTable [Bind] Exp - | EProd Decl Exp - | ETType Exp Exp - | ELet [LocDef] Exp - | ELetb [LocDef] Exp - | EWhere Exp [LocDef] - | EEqs [Equation] - | EExample Exp String - | ELString LString - | ELin PIdent - deriving (Eq,Ord,Show) - -data Exps = - NilExp - | ConsExp Exp Exps - deriving (Eq,Ord,Show) - -data Patt = - PChar - | PChars String - | PMacro PIdent - | PM PIdent PIdent - | PW - | PV PIdent - | PCon PIdent - | PQ PIdent PIdent - | PInt Integer - | PFloat Double - | PStr String - | PR [PattAss] - | PTup [PattTupleComp] - | PC PIdent [Patt] - | PQC PIdent PIdent [Patt] - | PDisj Patt Patt - | PSeq Patt Patt - | PRep Patt - | PAs PIdent Patt - | PNeg Patt - deriving (Eq,Ord,Show) - -data PattAss = - PA [PIdent] Patt - deriving (Eq,Ord,Show) - -data Label = - LPIdent PIdent - | LVar Integer - deriving (Eq,Ord,Show) - -data Sort = - Sort_Type - | Sort_PType - | Sort_Tok - | Sort_Str - | Sort_Strs - deriving (Eq,Ord,Show) - -data Bind = - BPIdent PIdent - | BWild - deriving (Eq,Ord,Show) - -data Decl = - DDec [Bind] Exp - | DExp Exp - deriving (Eq,Ord,Show) - -data TupleComp = - TComp Exp - deriving (Eq,Ord,Show) - -data PattTupleComp = - PTComp Patt - deriving (Eq,Ord,Show) - -data Case = - Case Patt Exp - deriving (Eq,Ord,Show) - -data Equation = - Equ [Patt] Exp - deriving (Eq,Ord,Show) - -data Altern = - Alt Exp Exp - deriving (Eq,Ord,Show) - -data DDecl = - DDDec [Bind] Exp - | DDExp Exp - deriving (Eq,Ord,Show) - -data OldGrammar = - OldGr Include [TopDef] - deriving (Eq,Ord,Show) - -data Include = - NoIncl - | Incl [FileName] - deriving (Eq,Ord,Show) - -data FileName = - FString String - | FPIdent PIdent - | FSlash FileName - | FDot FileName - | FMinus FileName - | FAddId PIdent FileName - deriving (Eq,Ord,Show) - diff --git a/src-3.0/GF/Devel/Compile/CheckGrammar.hs b/src-3.0/GF/Devel/Compile/CheckGrammar.hs deleted file mode 100644 index 30ea0a70e..000000000 --- a/src-3.0/GF/Devel/Compile/CheckGrammar.hs +++ /dev/null @@ -1,1089 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.31 $ --- --- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 -- 6/12/2007 --- --- type checking also does the following modifications: --- --- - types of operations and local constants are inferred and put in place --- --- - both these types and linearization types are computed --- --- - tables are type-annotated --- --- - overloading is resolved ------------------------------------------------------------------------------ - -module GF.Devel.Compile.CheckGrammar ( - showCheckModule, - justCheckLTerm, - allOperDependencies, - topoSortOpers - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.Lookup - -import GF.Infra.Ident - ---import GF.Grammar.Refresh ---- - ---import GF.Grammar.TypeCheck ---import GF.Grammar.Values (cPredefAbs) --- - - ---import GF.Grammar.LookAbs ---import GF.Grammar.ReservedWords ---- -import GF.Devel.Grammar.PatternMatch (testOvershadow) -import GF.Devel.Grammar.AppPredefined ---import GF.Grammar.Lockfield (isLockLabel) - -import GF.Devel.CheckM - -import GF.Data.Operations - -import Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace --- - - -showCheckModule :: GF -> SourceModule -> Err (SourceModule,String) -showCheckModule mos m = do - (st,(_,msg)) <- checkStart $ checkModule mos m - return (st, unlines $ reverse msg) - -checkModule :: GF -> SourceModule -> Check SourceModule -checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do - let gr = gf0 {gfmodules = Map.insert name mo (gfmodules gf0)} - ---- checkRestrictedInheritance gr (name, mo) - mo1 <- case mtype mo of - MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo - MTGrammar -> entryOpModule (checkResInfo gr name) mo - - MTConcrete aname -> do - checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo - abs <- checkErr $ lookupModule gr aname - mo1 <- checkCompleteGrammar abs mo - entryOpModule (checkCncInfo gr name (aname,abs)) mo1 - - MTInterface -> entryOpModule (checkResInfo gr name) mo - - MTInstance iname -> do - intf <- checkErr $ lookupModule gr iname - entryOpModule (checkResInfo gr name) mo - - return $ (name, mo1) - -{- ---- --- check if restricted inheritance modules are still coherent --- i.e. that the defs of remaining names don't depend on omitted names ----checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () -checkRestrictedInheritance mos (name,mo) = do - let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] - -- the restr. modules themself, with restr. infos - mapM_ checkRem mrs - where - checkRem ((i,m),mi) = do - let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) - let incld c = Set.member c (Set.fromList incl) - let illegal c = Set.member c (Set.fromList excl) - let illegals = [(f,is) | - (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] - case illegals of - [] -> return () - cs -> fail $ "In inherited module" +++ prt i ++ - ", dependence of excluded constants:" ++++ - unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | - (f,is) <- cs] - allDeps = ---- transClosure $ Map.fromList $ - concatMap (allDependencies (const True)) - [jments m | (_,ModMod m) <- mos] - transClosure ds = ds ---- TODO: check in deeper modules --} - - --- | check if a term is typable -justCheckLTerm :: GF -> Term -> Err Term -justCheckLTerm src t = do - ((t',_),_) <- checkStart (inferLType src t) - return t' - -checkAbsInfo :: GF -> Ident -> Judgement -> Check Judgement -checkAbsInfo st m info = return info ---- - -{- -checkAbsInfo st m (c,info) = do ----- checkReservedId c - case info of - AbsCat (Yes cont) _ -> mkCheck "category" $ - checkContext st cont ---- also cstrs - AbsFun (Yes typ0) md -> do - typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ checkTyp st typ - md' <- case md of - Yes d -> do - let d' = elimTables d - mkCheckWarn "definition of function" $ checkEquation st (m,c) d' - return $ Yes d' - _ -> return md - return $ (c,AbsFun (Yes typ) md') - _ -> return (c,info) - where - mkCheck cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c - ---- temporary solution when tc of defs is incomplete - mkCheckWarn cat ss = case ss of - [] -> return (c,info) - ["[]"] -> return (c,info) ---- - _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) - compAbsTyp g t = case t of - Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod x a b -> do - a' <- compAbsTyp g a - b' <- compAbsTyp ((x,Vr x):g) b - return $ Prod x a' b' - Abs _ _ -> return t - _ -> composOp (compAbsTyp g) t - - elimTables e = case e of - S t a -> elimSel (elimTables t) (elimTables a) - T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] - _ -> composSafeOp elimTables e - elimPatt p = case p of - PR lps -> map snd lps - _ -> [p] - elimSel t a = case a of - R fs -> mkApp t (map (snd . snd) fs) - _ -> mkApp t [a] --} - - -checkCompleteGrammar :: Module -> Module -> Check Module -checkCompleteGrammar abs cnc = do - let js = mjments cnc - let fs = Map.assocs $ mjments abs - js' <- foldM checkOne js fs - return $ cnc {mjments = js'} - where - checkOne js i@(c, ju) = case jform ju of - JFun -> case Map.lookup c js of - Just j | jform j == JLin -> return js - _ -> do - checkWarn $ "WARNING: no linearization of" +++ prt c - return js - JCat -> case Map.lookup c js of - Just j | jform ju == JLincat -> return js - _ -> do ---- TODO: other things to check here - checkWarn $ - "Warning: no linearization type for" +++ prt c ++ - ", inserting default {s : Str}" - return $ Map.insert c (cncCat defLinType) js - _ -> return js - -checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement -checkResInfo gr mo c info = do - ---- checkReservedId c - trace (show info) (return ()) - case jform info of - JOper -> chIn "operation" $ case (jtype info, jdef info) of - _ | isConstructor info -> return info - (_,Meta _) -> do - checkWarn "No definition given to oper" - return info - (Meta _,de) -> do - (de',ty') <- infer de - ---- trace ("inferred" +++ prt de' +++ ":" +++ prt ty') $ - return (resOper ty' de') - (ty, de) -> do - ty' <- check ty typeType >>= comp . fst - (de',_) <- check de ty' - return (resOper ty' de') -{- ---- - ResOverload tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip check) tysts - let tysts2 = [(y,x) | (x,y) <- tysts'] - --- this can only be a partial guarantee, since matching - --- with value type is only possible if expected type is given - checkUniq $ - sort [t : map snd xs | (x,_) <- tysts2, let (xs,t) = prodForm x] - return (c,ResOverload tysts2) --} -{- ---- - ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ----- mapM ((mapM (computeLType gr . snd)) . snd) pcs - mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs - ts <- checkErr $ lookupParamValues gr mo c - return (c,ResParam (Yes (pcs, Just ts))) --} - _ -> return info - where - infer = inferLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - comp = computeLType gr - - checkUniq xss = case xss of - x:y:xs - | x == y -> raise $ "ambiguous for argument list" +++ - unwords (map (prtType gr) x) - | otherwise -> checkUniq $ y:xs - _ -> return () - - -checkCncInfo :: GF -> Ident -> SourceModule -> - Ident -> Judgement -> Check Judgement -checkCncInfo gr cnc (a,abs) c info = do - ---- checkReservedId c - case jform info of - JFun -> chIn "linearization of" $ do - typ <- checkErr $ lookupFunType gr a c - cat0 <- checkErr $ valCat typ - (cont,val) <- linTypeOfType gr cnc typ -- creates arg vars - let lintyp = mkFunType (map snd cont) val - (trm',_) <- check (jdef info) lintyp -- erases arg vars - checkPrintname gr (jprintname info) - cat <- return $ snd cat0 - return (info {jdef = trm'}) - ---- return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) - -- cat for cf, typ for pe - - JCat -> chIn "linearization type of" $ do - checkErr $ lookupCatContext gr a c - typ' <- checkIfLinType gr (jtype info) - {- ---- - mdef' <- case mdef of - Yes def -> do - (def',_) <- checkLType gr def (mkFunType [typeStr] typ) - return $ Yes def' - _ -> return mdef - -} - checkPrintname gr (jprintname info) - return (info {jtype = typ'}) - - _ -> checkResInfo gr cnc c info - - where - env = gr - infer = inferLType gr - comp = computeLType gr - check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") - - -checkIfParType :: GF -> Type -> Check () -checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) - where - isParType ty = True ---- -{- case ty of - Cn typ -> case lookupConcrete st typ of - Ok (CncParType _ _ _) -> True - Ok (CncOper _ ty' _) -> isParType ty' - _ -> False - Q p t -> case lookupInPackage st (p,t) of - Ok (CncParType _ _ _) -> True - _ -> False - RecType r -> all (isParType . snd) r - _ -> False --} - -{- ---- -checkIfStrType :: SourceGrammar -> Type -> Check () -checkIfStrType st typ = case typ of - Table arg val -> do - checkIfParType st arg - checkIfStrType st val - _ | typ == typeStr -> return () - _ -> prtFail "not a string type" typ --} - -checkIfLinType :: GF -> Type -> Check Type -checkIfLinType st typ0 = do - typ <- computeLType st typ0 - case typ of - RecType r -> return () - _ -> prtFail "a linearization type must be a record type instead of" typ - return typ - -computeLType :: GF -> Type -> Check Type -computeLType gr t = do - g0 <- checkGetContext - let g = [(x, Vr x) | (x,_) <- g0] - checkInContext g $ comp t - where - comp ty = case ty of - - App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed - Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed - - Q m c | elem c [cPredef,cPredefAbs] -> return ty - Q m c | elem c [identC "Int"] -> - return $ defLinType ----- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in ----- RecType [ ----- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)] - Q m c | elem c [identC "Float",identC "String"] -> return defLinType ---- - - Q m ident -> checkIn ("module" +++ prt m) $ do - ty' <- checkErr (lookupOperDef gr m ident) - if ty' == ty then return ty else comp ty' --- is this necessary to test? - - Vr ident -> checkLookup ident -- never needed to compute! - - App f a -> do - f' <- comp f - a' <- comp a - case f' of - Abs x b -> checkInContext [(x,a')] $ comp b - _ -> return $ App f' a' - - Prod x a b -> do - a' <- comp a - b' <- checkInContext [(x,Vr x)] $ comp b - return $ Prod x a' b' - - Abs x b -> do - b' <- checkInContext [(x,Vr x)] $ comp b - return $ Abs x b' - - ExtR r s -> do - r' <- comp r - s' <- comp s - case (r',s') of - (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs - liftM RecType $ mapPairsM comp fs' - - _ | ty == typeTok -> return typeStr ---- deprecated - _ | isPredefConstant ty -> return ty - - _ -> composOp comp ty - -checkPrintname :: GF -> Term -> Check () ----- checkPrintname st (Yes t) = checkLType st t typeStr >> return () -checkPrintname _ _ = return () - -{- ---- --- | for grammars obtained otherwise than by parsing ---- update!! -checkReservedId :: Ident -> Check () -checkReservedId x = let c = prt x in - if isResWord c - then checkWarn ("Warning: reserved word used as identifier:" +++ c) - else return () --} - --- to normalize records and record types -labelIndex :: Type -> Label -> Int -labelIndex ty lab = case ty of - RecType ts -> maybe (error ("label index"+++ prt lab)) id $ lookup lab $ labs ts - _ -> error $ "label index" +++ prt ty - where - labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] - --- the underlying algorithms - -inferLType :: GF -> Term -> Check (Term, Type) -inferLType gr trm = case trm of - - Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - Q m ident -> checks [ - termWith trm $ checkErr (lookupOperType gr m ident) >>= comp - , - checkErr (lookupOperDef gr m ident) >>= infer - , -{- - do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> prtFail "not overloaded" trm - , --} - prtFail "cannot infer type of constant" trm - ] - - QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - QC m ident -> checks [ - termWith trm $ checkErr (lookupOperType gr m ident) >>= comp --- ,checkErr (lookupOperDef gr m ident) >>= infer --- ,prtFail "cannot infer type of canonical constant" trm - ] - - Val ty i -> termWith trm $ return ty - - Vr ident -> termWith trm $ checkLookup ident - - Typed e t -> do - t' <- comp t - check e t' - return (e,t') - - App f a -> do - over <- getOverload gr Nothing trm - case over of - Just trty -> return trty - _ -> do - (f',fty) <- infer f - fty' <- comp fty - case fty' of - Prod z arg val -> do - a' <- justCheck a arg - ty <- if isWildIdent z - then return val - else substituteLType [(z,a')] val - return (App f' a',ty) - _ -> raise ("function type expected for"+++ - prt f +++"instead of" +++ prtType env fty) - - S f x -> do - (f', fty) <- infer f - case fty of - Table arg val -> do - x'<- justCheck x arg - return (S f' x', val) - _ -> prtFail "table lintype expected for the table in" trm - - P t i -> do - (t',ty) <- infer t --- ?? - ty' <- comp ty ------ let tr2 = PI t' i (labelIndex ty' i) - let tr2 = P t' i - termWith tr2 $ checkErr $ case ty' of - RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ - lookup i ts - _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' - PI t i _ -> infer $ P t i - - R r -> do - let (ls,fs) = unzip r - fsts <- mapM inferM fs - let ts = [ty | (Just ty,_) <- fsts] - checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) - return $ (R (zip ls fsts), RecType (zip ls ts)) - - T (TTyped arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - check trm (Table arg val) - T (TComp arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - check trm (Table arg val) - T ti pts -> do -- tries to guess: good in oper type inference - let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] - case pts' of - [] -> prtFail "cannot infer table type of" trm ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - check trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map infer pts - return (trm, Table arg val) - - K s -> do - if elem ' ' s - then checkWarn ("WARNING: space in token \"" ++ s ++ - "\". Lexical analysis may fail.") - else return () - return (trm, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - EParam _ cos -> return (trm, typePType) ---- check cos - - C s1 s2 -> - check2 (flip justCheck typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip justCheck typeStr) Glue s1 s2 typeStr - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 ----- Strs (Cn (IC "#conflict") : ts) -> do ----- trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) --- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) --- infer $ head ts - - - Alts (t,aa) -> do - t' <- justCheck t typeStr - aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck c typeStr - v' <- justCheck v typeStr - return (c',v')) - return (Alts (t',aa'), typeStr) - - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM (flip justCheck typeType) ts - return (RecType (zip ls ts'), typeType) - - ExtR r s -> do - (r',rT) <- infer r - rT' <- comp rT - (s',sT) <- infer s - sT' <- comp sT - - let trm' = ExtR r' s' - ---- trm' <- checkErr $ plusRecord r' s' - case (rT', sT') of - (RecType rs, RecType ss) -> do - rt <- checkErr $ plusRecType rT' sT' - check trm' rt ---- return (trm', rt) - _ | rT' == typeType && sT' == typeType -> return (trm', typeType) - _ -> prtFail "records or record types expected in" trm - - Sort _ -> - termWith trm $ return typeType - - Prod x a b -> do - a' <- justCheck a typeType - b' <- checkInContext [(x,a')] $ justCheck b typeType - return (Prod x a' b', typeType) - - Table p t -> do - p' <- justCheck p typeType --- check p partype! - t' <- justCheck t typeType - return $ (Table p' t', typeType) - - FV vs -> do - (_,ty) <- checks $ map infer vs ---- checkIfComplexVariantType trm ty - check trm ty - - EPattType ty -> do - ty' <- justCheck ty typeType - return (ty',typeType) - EPatt p -> do - ty <- inferPatt p - return (trm, EPattType ty) - _ -> prtFail "cannot infer lintype of" trm - - where - env = gr - infer = inferLType env - comp = computeLType env - - check = checkLType env - - isPredef m = elem m [cPredef,cPredefAbs] - - justCheck ty te = check ty te >>= return . fst - - -- for record fields, which may be typed - inferM (mty, t) = do - (t', ty') <- case mty of - Just ty -> check ty t - _ -> infer t - return (Just ty',t') - - inferCase mty (patt,term) = do - arg <- maybe (inferPatt patt) return mty - cont <- pattContext env arg patt - i <- checkUpdates cont - (_,val) <- infer term - checkResets i - return (arg,val) - isConstPatt p = case p of - PC _ ps -> True --- all isConstPatt ps - PP _ _ ps -> True --- all isConstPatt ps - PR ps -> all (isConstPatt . snd) ps - PT _ p -> isConstPatt p - PString _ -> True - PInt _ -> True - PFloat _ -> True - PSeq p q -> isConstPatt p || isConstPatt q - PAlt p q -> isConstPatt p || isConstPatt q - PRep p -> isConstPatt p - PNeg p -> isConstPatt p - PAs _ p -> isConstPatt p - PChar -> True - PChars _ -> True - _ -> False - - inferPatt p = case p of - PP q c ps | q /= cPredef -> - checkErr $ lookupOperType gr q c >>= return . snd . prodForm - PAs _ p -> inferPatt p - PNeg p -> inferPatt p - PAlt p q -> checks [inferPatt p, inferPatt q] - PSeq _ _ -> return $ typeStr - PRep _ -> return $ typeStr - PChar -> return $ typeStr - PChars _ -> return $ typeStr - _ -> infer (patt2term p) >>= return . snd - - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: GF -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload env@gr mt t = case appForm t of - (f@(Q m c), ts) -> case lookupOverload gr m c of - Ok typs -> do - ttys <- mapM infer ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - _ -> return Nothing - where - infer = inferLType env - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - - case [vf | vf@(v,f) <- vfs, matchVal mt v] of - [(val,fun)] -> return (mkApp fun tts, val) - [] -> raise $ "no overload instance of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ - unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ - maybe [] (("with value type" +++) . prtType env) mt - - ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" - ---- ++++ unlines (map (show . fst) typs) ---- - - vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of - [(val,fun)] -> do - checkWarn $ "WARNING: overloading of" +++ prt f +++ - "resolved by excluding partial applications:" ++++ - unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - return (mkApp fun tts, val) - - _ -> raise $ "ambiguous overloading of" +++ prt f +++ - "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ - unlines [prtType env ty | (ty,_) <- vfs'] - - matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where - unlocked = case v of - RecType fs -> [Just $ RecType $ fs] ---- filter (not . isLockLabel . fst) fs] - _ -> [] - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [(mkFunType rest val, t) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - pre == tys - ] - - noProd ty = case ty of - Prod _ _ _ -> False - _ -> True - -checkLType :: GF -> Term -> Type -> Check (Term, Type) -checkLType env trm typ0 = do - trace (show trm) (return ()) - - typ <- comp typ0 - - case trm of - - Abs x c -> do - case typ of - Prod z a b -> do - checkUpdate (x,a) - (c',b') <- if isWildIdent z - then check c b - else do - b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b - check c b' - checkReset - return $ (Abs x c', Prod x a b') - _ -> raise $ "product expected instead of" +++ prtType env typ - - App f a -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - Q _ _ -> do - over <- getOverload env (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - - EData -> return (trm,typ) - - T _ [] -> - prtFail "found empty table in type" typ - T _ cs -> case typ of - Table arg val -> do - case allParamValues env arg of - Ok vs -> do - let ps0 = map fst cs - ps <- return [] ---- checkErr $ testOvershadow ps0 vs - if null ps - then return () - else checkWarn $ "WARNING: patterns never reached:" - ---- +++ concat (intersperse ", " (map prt ps)) - - _ -> return () -- happens with variable types - cs' <- mapM (checkCase arg val) cs - return (T (TTyped arg) cs', typ) - _ -> raise $ "table type expected for table instead of" +++ prtType env typ - - R r -> case typ of --- why needed? because inference may be too difficult - RecType rr -> do - let (ls,_) = unzip rr -- labels of expected type - fsts <- mapM (checkM r) rr -- check that they are found in the record - return $ (R fsts, typ) -- normalize record - - _ -> prtFail "record type expected in type checking instead of" typ - - ExtR r s -> case typ of - _ | typ == typeType -> do - trm' <- comp trm - case trm' of - RecType _ -> termWith trm $ return typeType - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType - -- ext t = t ** ... - _ -> prtFail "invalid record type extension" trm - RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- infer r - return (r',ty,s) - , - do (s',ty) <- infer s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck r' rr0 - s2 <- justCheck s' rr2 - return $ (ExtR r2 s2, typ) - _ -> raise ("record type expected in extension of" +++ prt r +++ - "but found" +++ prt ty) - - ExtR ty ex -> do - r' <- justCheck r ty - s' <- justCheck s ex - return $ (ExtR r' s', typ) --- is this all? - - _ -> prtFail "record extension not meaningful for" typ - - FV vs -> do - ttys <- mapM (flip check typ) vs ---- checkIfComplexVariantType trm typ - return (FV (map fst ttys), typ) --- typ' ? - - S tab arg -> checks [ do - (tab',ty) <- infer tab - ty' <- comp ty - case ty' of - Table p t -> do - (arg',val) <- check arg p - checkEq typ t trm - return (S tab' arg', t) - _ -> raise $ "table type expected for applied table instead of" +++ - prtType env ty' - , do - (arg',ty) <- infer arg - ty' <- comp ty - (tab',_) <- check tab (Table ty' typ) - return (S tab' arg', typ) - ] - Let (x,(mty,def)) body -> case mty of - Just ty -> do - (def',ty') <- check def ty - checkUpdate (x,ty') - body' <- justCheck body typ - checkReset - return (Let (x,(Just ty',def')) body', typ) - _ -> do - (def',ty) <- infer def -- tries to infer type of local constant - check (Let (x,(Just ty,def')) body) typ - - _ -> do - (trm',ty') <- infer trm - termWith trm' $ checkEq typ ty' trm' - where - cnc = env - infer = inferLType env - comp = computeLType env - - check = checkLType env - - justCheck ty te = check ty te >>= return . fst - - checkEq = checkEqLType env - - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr - - checkM rms (l,ty) = case lookup l rms of - Just (Just ty0,t) -> do - checkEq ty ty0 t - (t',ty') <- check t ty - return (l,(Just ty',t')) - Just (_,t) -> do - (t',ty') <- check t ty - return (l,(Just ty',t')) - _ -> prtFail "cannot find value for label" l - - checkCase arg val (p,t) = do - cont <- pattContext env arg p - i <- checkUpdates cont - t' <- justCheck t val - checkResets i - return (p,t') - -pattContext :: LTEnv -> Type -> Patt -> Check Context -pattContext env typ p = case p of - PV x | not (isWildIdent x) -> return [(x,typ)] - PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- checkErr $ lookupOperType cnc q c - let (cont,v) = prodForm t - checkCond ("wrong number of arguments for constructor in" +++ prt p) - (length cont == length ps) - checkEqLType env typ v (patt2term p) - mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat - PR r -> do - typ' <- computeLType env typ - case typ' of - RecType t -> do - let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] - ----- checkWarn $ prt p ++++ show pts ----- debug - mapM (uncurry (pattContext env)) pts >>= return . concat - _ -> prtFail "record type expected for pattern instead of" typ' - PT t p' -> do - checkEqLType env typ t (patt2term p') - pattContext env typ p' - - PAs x p -> do - g <- pattContext env typ p - return $ (x,typ):g - - PAlt p' q -> do - g1 <- pattContext env typ p' - g2 <- pattContext env typ q - let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] - checkCond - ("incompatible bindings of" +++ - unwords (nub (map (prt . fst) pts))+++ - "in pattern alterantives" +++ prt p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env typ p - g2 <- pattContext env typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - cnc = env - noBind typ p' = do - co <- pattContext env typ p' - if not (null co) - then checkWarn ("no variable bound inside pattern" +++ prt p) - >> return [] - else return [] - --- auxiliaries - -type LTEnv = GF - -termWith :: Term -> Check Type -> Check (Term, Type) -termWith t ct = do - ty <- ct - return (t,ty) - --- | light-weight substitution for dep. types -substituteLType :: Context -> Type -> Check Type -substituteLType g t = case t of - Vr x -> return $ maybe t id $ lookup x g - _ -> composOp (substituteLType g) t - --- | compositional check\/infer of binary operations -check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> - Term -> Term -> Type -> Check (Term,Type) -check2 chk con a b t = do - a' <- chk a - b' <- chk b - return (con a' b', t) - -checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type -checkEqLType env t u trm = do - (b,t',u',s) <- checkIfEqLType env t u trm - case b of - True -> return t' - False -> raise $ s +++ "type of" +++ prt trm +++ - ": expected:" +++ prtType env t ++++ - "inferred:" +++ prtType env u - -checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType env t u trm = do - t' <- comp t - u' <- comp u - case t' == u' || alpha [] t' u' of - True -> return (True,t',u',[]) - -- forgive missing lock fields by only generating a warning. - --- better: use a flag to forgive? (AR 31/1/2006) - _ -> case missingLock [] t' u' of - Ok lo -> do - checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) - return (True,t',u',[]) - Bad s -> return (False,t',u',s) - - where - - -- t is a subtype of u - --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of - - -- error (the empty type!) is subtype of any other type - (_,Q (IC "Predef") (IC "Error")) -> True - - -- unknown type unifies with any type ---- - (_,Meta _) -> True - - -- contravariance - (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d - - -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> alpha g a b && l == k) ts) rs - (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' - (ExtR r s, t) -> alpha g r t || alpha g s t - - -- the following say that Ints n is a subset of Int and of Ints m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n - (App (Q (IC "Predef") (IC "Ints")) (EInt n), - Q (IC "Predef") (IC "Int")) -> True ---- check size! - - (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 - App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True - - ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - || m == n --- for Predef - (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) - || elem n (allExtendsPlus env m) - - (Table a b, Table c d) -> alpha g a c && alpha g b d - (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g - _ -> t == u - --- the following should be one-way coercions only. AR 4/1/2001 - || elem t sTypes && elem u sTypes - || (t == typeType && u == typePType) - || (u == typeType && t == typePType) - - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, - not (any (\ (k,b) -> alpha g a b && l == k) ts)] - (locks,others) = partition (const False) ls ---- isLockLabel ls - in case others of - _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) - _ -> return locks - -- contravariance - (Prod x a b, Prod y c d) -> do - ls1 <- missingLock g c a - ls2 <- missingLock g b d - return $ ls1 ++ ls2 - - _ -> Bad "" - - ---- to revise - allExtendsPlus _ n = [n] - - sTypes = [typeStr, typeString, typeTok] ---- Tok deprecated - comp = computeLType env - --- printing a type with a lock field lock_C as C -prtType :: LTEnv -> Type -> String -prtType env ty = case ty of - RecType fs -> ---- case filter isLockLabel $ map fst fs of - ---- [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty - ---- _ -> - prtt ty - Prod x a b -> prtType env a +++ "->" +++ prtType env b - _ -> prtt ty - where - prtt t = prt t - ---- use computeLType gr to check if really equal to the cat with lock - - --- | linearization types and defaults -linTypeOfType :: GF -> Ident -> Type -> Check (Context,Type) -linTypeOfType cnc m typ = do - (cont,cat) <- checkErr $ typeSkeleton typ - val <- lookLin cat - args <- mapM mkLinArg (zip [0..] cont) - return (args, val) - where - mkLinArg (i,(n,mc@(m,cat))) = do - val <- lookLin mc - let vars = mkRecType varLabel $ replicate n typeStr - symb = argIdent n cat i - rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ - plusRecType vars val - return (symb,rec) - lookLin (_,c) = checks [ --- rather: update with defLinType ? - checkErr (lookupLincat cnc m c) >>= computeLType cnc - ,return defLinType - ] - --- | dependency check, detecting circularities and returning topo-sorted list - -allOperDependencies :: Ident -> Map.Map Ident Judgement -> [(Ident,[Ident])] -allOperDependencies m = allDependencies (==m) - -allDependencies :: (Ident -> Bool) -> Map.Map Ident Judgement -> [(Ident,[Ident])] -allDependencies ism b = - [(f, nub (concatMap opersIn (pts i))) | (f,i) <- Map.assocs b] - where - opersIn t = case t of - Q n c | ism n -> [c] - QC n c | ism n -> [c] - _ -> collectOp opersIn t - pts i = [jtype i, jdef i] - ---- AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual - -topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] -topoSortOpers st = do - let eops = topoTest st - either - return - (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) - eops diff --git a/src-3.0/GF/Devel/Compile/Compile.hs b/src-3.0/GF/Devel/Compile/Compile.hs deleted file mode 100644 index 07e059ed4..000000000 --- a/src-3.0/GF/Devel/Compile/Compile.hs +++ /dev/null @@ -1,205 +0,0 @@ -module GF.Devel.Compile.Compile (batchCompile) where - --- the main compiler passes -import GF.Devel.Compile.GetGrammar -import GF.Devel.Compile.Extend -import GF.Devel.Compile.Rename -import GF.Devel.Compile.CheckGrammar -import GF.Devel.Compile.Refresh -import GF.Devel.Compile.Optimize -import GF.Devel.Compile.Factorize - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Infra.Ident -import GF.Devel.Grammar.PrGF -----import GF.Devel.Grammar.Lookup -import GF.Devel.Infra.ReadFiles - -import GF.Infra.Option ---- -import GF.Data.Operations -import GF.Devel.UseIO -import GF.Devel.Arch - -import Control.Monad -import System.Directory - -batchCompile :: Options -> [FilePath] -> IO GF -batchCompile opts files = do - let defOpts = addOptions opts (options [emitCode]) - egr <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files - case egr of - Ok (_,gr) -> return gr - Bad s -> error s - --- to output an intermediate stage -intermOut :: Options -> Option -> String -> IOE () -intermOut opts opt s = - if oElem opt opts || oElem (iOpt "show_all") opts - then - ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) - else - return () - -prMod :: SourceModule -> String -prMod = prModule - --- | the environment -type CompileEnv = (Int,GF) - --- | compile with one module as starting point --- command-line options override options (marked by --#) in the file --- As for path: if it is read from file, the file path is prepended to each name. --- If from command line, it is used as it is. - -compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv -compileModule opts1 env file = do - opts0 <- ioeIO $ getOptionsFromFile file - let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList - let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList - let opts = addOptions opts1 opts0 - let fpath = dropFileName file - ps0 <- ioeIO $ pathListOpts opts fpath - - let ps1 = if (useFileOpt && not useLineOpt) - then (ps0 ++ map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) - ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- - let sgr = snd env - let rfs = [] ---- files already in memory and their read times - let file' = if useFileOpt then takeFileName file else file -- find file itself - files <- getAllFiles opts ps rfs file' - ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- - let names = map justModuleName files - ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- - let sgr2 = sgr ----MGrammar [m | m@(i,_) <- modules sgr, - ---- notElem (prt i) $ map dropExtension names] - let env0 = (0,sgr2) - (e,mm) <- foldIOE (compileOne opts) env0 files - maybe (return ()) putStrLnE mm - return e - - -compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv -compileOne opts env@(_,srcgr) file = do - - let putp s = putPointE opts ("\n" ++ s) - let putpp = putPointEsil opts - let putpOpt v m act - | oElem beVerbose opts = putp v act - | oElem beSilent opts = putpp v act - | otherwise = ioeIO (putStrFlush ("\n" ++ m)) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = gfmodules srcgr - - case gf of - - -- for compiled gf, read the file and update environment - -- also undo common subexp optimization, to enable normal computations - - ".gfn" -> do - sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 - extendCompileEnv env sm - - -- for gf source, do full compilation and generate code - _ -> do - - let modu = dropExtension file - b1 <- ioeIO $ doesFileExist file - if not b1 - then compileOne opts env $ gfoFile $ modu - else do - - sm0 <- - putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm) <- compileSourceModule opts env sm0 - let sm1 = sm ---- ----- if isConcr sm then shareModule sm else sm -- cannot expand Str - if oElem (iOpt "doemit") opts - then putpp " generating code... " $ generateModuleCode opts path sm1 - else return () ----- -- sm is optimized before generation, but not in the env ----- let cm2 = unsubexpModule cm - extendCompileEnvInt env (k',sm) ---- sm1 - where - isConcr (_,mi) = case mi of ----- ModMod m -> isModCnc m && mstatus m /= MSIncomplete - _ -> False - - - -compileSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule) -compileSourceModule opts env@(k,gr) mo@(i,mi) = do - - intermOut opts (iOpt "show_gf") (prMod mo) - - let putp = putPointE opts - putpp = putPointEsil opts - stopIf n comp m = - if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return m else comp m - stopIfV v n comp m = - if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return (m,v) else comp m - - moe <- stopIf 1 (putpp " extending" . ioeErr . extendModule gr) mo - intermOut opts (iOpt "show_extend") (prMod moe) - - mor <- stopIf 2 (putpp " renaming" . ioeErr . renameModule gr) moe - intermOut opts (iOpt "show_rename") (prMod mor) - - (moc,warnings) <- - stopIfV [] 3 (putpp " type checking" . ioeErr . showCheckModule gr) mor - if null warnings then return () else putp warnings $ return () - intermOut opts (iOpt "show_typecheck") (prMod moc) - - (mox,k') <- stopIfV k 4 (putpp " refreshing " . ioeErr . refreshModule k) moc - intermOut opts (iOpt "show_refresh") (prMod mox) - - moo <- stopIf 5 (putpp " optimizing " . ioeErr . optimizeModule opts gr) mox - intermOut opts (iOpt "show_optimize") (prMod moo) - - mof <- stopIf 6 (putpp " factorizing " . ioeErr . optimizeModule opts gr) moo - intermOut opts (iOpt "show_factorize") (prMod mof) - - return (k',moo) ---- - - -generateModuleCode :: Options -> InitPath -> SourceModule -> IOE () -generateModuleCode opts path minfo@(name,info) = do - - let pname = combine path (prt name) - let minfo0 = minfo - let minfo1 = subexpModule minfo0 - let minfo2 = minfo1 - - let (file,out) = (gfoFile pname, prGF (gfModules [minfo2])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ out - - return () ----- minfo2 - where - putp = putPointE opts - putpp = putPointEsil opts - --- auxiliaries - -pathListOpts :: Options -> FileName -> IO [InitPath] -pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList - -----reverseModules (MGrammar ms) = MGrammar $ reverse ms - -emptyCompileEnv :: CompileEnv -emptyCompileEnv = (0,emptyGF) - -extendCompileEnvInt (_,gf) (k,(s,m)) = return (k, addModule s m gf) - -extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm) - - diff --git a/src-3.0/GF/Devel/Compile/ErrM.hs b/src-3.0/GF/Devel/Compile/ErrM.hs deleted file mode 100644 index 9cad4e252..000000000 --- a/src-3.0/GF/Devel/Compile/ErrM.hs +++ /dev/null @@ -1,26 +0,0 @@ --- BNF Converter: Error Monad --- Copyright (C) 2004 Author: Aarne Ranta - --- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. -module GF.Devel.Compile.ErrM where - --- the Error monad: like Maybe type with error msgs - -import Control.Monad (MonadPlus(..), liftM) - -data Err a = Ok a | Bad String - deriving (Read, Show, Eq, Ord) - -instance Monad Err where - return = Ok - fail = Bad - Ok a >>= f = f a - Bad s >>= f = Bad s - -instance Functor Err where - fmap = liftM - -instance MonadPlus Err where - mzero = Bad "Err.mzero" - mplus (Bad _) y = y - mplus x _ = x diff --git a/src-3.0/GF/Devel/Compile/Extend.hs b/src-3.0/GF/Devel/Compile/Extend.hs deleted file mode 100644 index 2f1aae65b..000000000 --- a/src-3.0/GF/Devel/Compile/Extend.hs +++ /dev/null @@ -1,154 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Extend --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 21:08:14 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- AR 14\/5\/2003 -- 11\/11 --- 4/12/2007 this module is still very very messy... ---- --- --- The top-level function 'extendModule' --- extends a module symbol table by indirections to the module it extends ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Extend ( - extendModule - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.Lookup -import GF.Devel.Grammar.Macros - -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.List (nub) -import Data.Map -import Control.Monad - -extendModule :: GF -> SourceModule -> Err SourceModule -extendModule gf nmo0 = do - (name,mo) <- rebuildModule gf nmo0 - case mtype mo of - - ---- Just to allow inheritance in incomplete concrete (which are not - ---- compiled anyway), extensions are not built for them. - ---- Should be replaced by real control. AR 4/2/2005 - MTConcrete _ | not (isCompleteModule mo) -> return (name,mo) - _ -> do - mo' <- foldM (extOne name) mo (mextends mo) - return (name, mo') - where - extOne name mo (n,cond) = do - mo0 <- lookupModule gf n - - -- test that the module types match - testErr True ---- (legalExtension mo mo0) - ("illegal extension type to module" +++ prt name) - - -- find out if the old is complete - let isCompl = isCompleteModule mo0 - - -- if incomplete, remove it from extension list --- because?? - let me' = (if isCompl then id else (Prelude.filter ((/=n) . fst))) - (mextends mo) - - -- build extension depending on whether the old module is complete - js0 <- extendMod isCompl n (isInherited cond) name (mjments mo0) (mjments mo) - - return $ mo {mextends = me', mjments = js0} - --- | When extending a complete module: new information is inserted, --- and the process is interrupted if unification fails. --- If the extended module is incomplete, its judgements are just copied. -extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident -> - Map Ident Judgement -> Map Ident Judgement -> - Err (Map Ident Judgement) -extendMod isCompl name cond base old new = foldM try new $ assocs old where - try t i@(c,_) | not (cond c) = return t - try t i@(c,_) = errIn ("constant" +++ prt c) $ - tryInsert (extendAnyInfo isCompl name base) indirIf t i - indirIf = if isCompl then indirInfo name else id - -indirInfo :: Ident -> Judgement -> Judgement -indirInfo n ju = case jform ju of - JLink -> ju -- original link is passed - _ -> linkInherited (isConstructor ju) n - -extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement -extendAnyInfo isc n o i j = - errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ - unifyJudgement i j - -tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> - Map a b -> (a,b) -> Err (Map a b) -tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of - Just info0 -> do - info1 <- unif info info0 - return $ insert x info1 tree - _ -> return $ insert x (indir info) tree - --- | rebuilding instance + interface, and "with" modules, prior to renaming. --- AR 24/10/2003 -rebuildModule :: GF -> SourceModule -> Err SourceModule -rebuildModule gr mo@(i,mi) = case mtype mi of - - -- copy interface contents to instance - MTInstance i0 -> do - m0 <- lookupModule gr i0 - testErr (isInterface m0) ("not an interface:" +++ prt i0) - js1 <- extendMod False i0 (const True) i (mjments m0) (mjments mi) - - --- to avoid double inclusions, in instance J of I0 = J0 ** ... - case mextends mi of - [] -> return $ (i,mi {mjments = js1}) - es -> do - mes <- mapM (lookupModule gr . fst) es ---- restricted?? 12/2007 - let notInExts c _ = all (notMember c . mjments) mes - let js2 = filterWithKey notInExts js1 - return $ (i,mi { - mjments = js2 - }) - - -- copy functor contents to instantiation, and also add opens - _ -> case minstances mi of - [((ext,incl),ops)] -> do - let interfs = Prelude.map fst ops - - -- test that all interfaces are instantiated - let isCompl = Prelude.null [i | (_,i) <- minterfaces mi, notElem i interfs] - testErr isCompl ("module" +++ prt i +++ "remains incomplete") - - -- look up the functor and build new opens set - mi0 <- lookupModule gr ext - let - ops1 = nub $ - mopens mi -- own opens; N.B. mi0 has been name-resolved already - ++ ops -- instantiating opens - ++ [(n,o) | - (n,o) <- mopens mi0, notElem o interfs] -- ftor's non-if opens - ++ [(i,i) | i <- Prelude.map snd ops] ---- -- insts w. real names - - -- combine flags; new flags have priority - let fs1 = union (mflags mi) (mflags mi0) - - -- copy inherited functor judgements - let js0 = [ci | ci@(c,_) <- assocs (mjments mi0), isInherited incl c] - let js1 = fromList (assocs (mjments mi) ++ js0) - - return $ (i,mi { - mflags = fs1, - mextends = mextends mi, -- extends of instantiation - mopens = ops1, - mjments = js1 - }) - _ -> return (i,mi) - diff --git a/src-3.0/GF/Devel/Compile/Factorize.hs b/src-3.0/GF/Devel/Compile/Factorize.hs deleted file mode 100644 index 7386f3ed5..000000000 --- a/src-3.0/GF/Devel/Compile/Factorize.hs +++ /dev/null @@ -1,251 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OptimizeGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Optimizations on GF source code: sharing, parametrization, value sets. --- --- optimization: sharing branches in tables. AR 25\/4\/2003. --- following advice of Josef Svenningsson ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Factorize ( - optModule, - unshareModule, - unsubexpModule, - unoptModule, - subexpModule, - shareModule - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.PrGF (prt) -import qualified GF.Devel.Grammar.Macros as C - -import GF.Devel.Grammar.Lookup -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List - -optModule :: SourceModule -> SourceModule -optModule = subexpModule . shareModule - -shareModule = processModule optim - -unoptModule :: GF -> SourceModule -> SourceModule -unoptModule gr = unshareModule gr . unsubexpModule - -unshareModule :: GF -> SourceModule -> SourceModule -unshareModule gr = processModule (const (unoptim gr)) - -processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule -processModule opt (i,mo) = - (i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)}) - -shareInfo :: (Term -> Term) -> Judgement -> Judgement -shareInfo opt ju = ju {jdef = opt (jdef ju)} - --- the function putting together optimizations -optim :: Ident -> Term -> Term -optim c = values . factor c 0 - --- we need no counter to create new variable names, since variables are --- local to tables ---- --- factor parametric branches - -factor :: Ident -> Int -> Term -> Term -factor c i t = case t of - T _ [_] -> t - T _ [] -> t - T (TComp ty) cs -> - T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs] - _ -> C.composSafeOp (factor c i) t - where - - factors i psvs = -- we know psvs has at least 2 elements - let p = qqIdent c i - vs' = map (mkFun p) psvs - in if allEqs vs' - then mkCase p vs' - else psvs - - mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val - - allEqs (v:vs) = all (==v) vs - - mkCase p (v:_) = [(PV p, v)] - ---- we hope this will be fresh and don't check... - -qqIdent c i = identC ("_q_" ++ prt c ++ "__" ++ show i) - - --- we need to replace subterms - -replace :: Term -> Term -> Term -> Term -replace old new trm = case trm of - - -- these are the important cases, since they can correspond to patterns - QC _ _ | trm == old -> new - App t ts | trm == old -> new - App t ts -> App (repl t) (repl ts) - R _ | isRec && trm == old -> new - _ -> C.composSafeOp repl trm - where - repl = replace old new - isRec = case trm of - R _ -> True - _ -> False - --- It is very important that this is performed only after case --- expansion since otherwise the order and number of values can --- be incorrect. Guaranteed by the TComp flag. - -values :: Term -> Term -values t = case t of - T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization - T (TComp ty) cs -> V ty [values t | (_, t) <- cs] - T (TTyped ty) cs -> V ty [values t | (_, t) <- cs] - ---- why are these left? - ---- printing with GrammarToSource does not preserve the distinction - _ -> C.composSafeOp values t - - --- to undo the effect of factorization - -unoptim :: GF -> Term -> Term -unoptim gr = unfactor gr - -unfactor :: GF -> Term -> Term -unfactor gr t = case t of - T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] - _ -> C.composSafeOp unfac t - where - unfac = unfactor gr - vals = err error id . allParamValues gr - restore x u t = case t of - Vr y | y == x -> u - _ -> C.composSafeOp (restore x u) t - - ----------------------------------------------------------------------- - -{- -This module implements a simple common subexpression elimination - for gfc grammars, to factor out shared subterms in lin rules. -It works in three phases: - - (1) collectSubterms collects recursively all subterms of forms table and (P x..y) - from lin definitions (experience shows that only these forms - tend to get shared) and counts how many times they occur - (2) addSubexpConsts takes those subterms t that occur more than once - and creates definitions of form "oper A''n = t" where n is a - fresh number; notice that we assume no ids of this form are in - scope otherwise - (3) elimSubtermsMod goes through lins and the created opers by replacing largest - possible subterms by the newly created identifiers - -The optimization is invoked in gf by the flag i -subs. - -If an application does not support GFC opers, the effect of this -optimization can be undone by the function unSubelimCanon. - -The function unSubelimCanon can be used to diagnostisize how much -cse is possible in the grammar. It is used by the flag pg -printer=subs. - --} - -subexpModule :: SourceModule -> SourceModule -subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of - MTAbstract -> return (m,mo) - _ -> do - let js = listJudgements mo - (tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0) - js2 <- addSubexpConsts m tree js - return (m, mo{mjments = Map.fromList js2}) - -unsubexpModule :: SourceModule -> SourceModule -unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)}) - where - unparInfo (c, ju) = case jtype ju of - EInt 8 -> [] -- subexp-generated opers - _ -> [(c, ju {jdef = unparTerm (jdef ju)})] - unparTerm t = case t of - Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers - maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo) - _ -> C.composSafeOp unparTerm t - rebuild = Map.fromList . concat . map unparInfo . Map.assocs - --- implementation - -type TermList = Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: - Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)] -addSubexpConsts mo tree lins = do - let opers = [oper id trm | (trm,(_,id)) <- list] - mapM mkOne $ opers ++ lins - where - - mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)}) - recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> Q mo (ident id) - _ -> C.composSafeOp (recomp f) t - - list = Map.toList tree - - oper id trm = (ident id, resOper (EInt 8) trm) - --- impossible type encoding generated opers - -getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int)) -getSubtermsMod mo js = do - mapM (getInfo (collectSubterms mo)) js - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getInfo get fi@(_,i) = do - get (jdef i) - return $ fi - -collectSubterms :: Ident -> Term -> TermM Term -collectSubterms mo t = case t of - App f a -> do - collect f - collect a - add t - T ty cs -> do - let (_,ts) = unzip cs - mapM collect ts - add t - V ty ts -> do - mapM collect ts - add t ----- K (KP _ _) -> add t - _ -> C.composOp (collectSubterms mo) t - where - collect = collectSubterms mo - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - return t --- only because of composOp - -ident :: Int -> Ident -ident i = identC ("_A" ++ show i) --- - diff --git a/src-3.0/GF/Devel/Compile/GF.cf b/src-3.0/GF/Devel/Compile/GF.cf deleted file mode 100644 index 3edbdf347..000000000 --- a/src-3.0/GF/Devel/Compile/GF.cf +++ /dev/null @@ -1,326 +0,0 @@ --- AR 2/5/2003, 14-16 o'clock, Torino - --- 17/6/2007: marked with suffix --% those lines that are obsolete and --- should not be included in documentation - -entrypoints Grammar, ModDef, - OldGrammar, --% - Exp ; -- let's see if more are needed - -comment "--" ; -comment "{-" "-}" ; - - --- identifiers - -position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ; - --- the top-level grammar - -Gr. Grammar ::= [ModDef] ; - --- semicolon after module is permitted but not obligatory - -terminator ModDef "" ; -_. ModDef ::= ModDef ";" ; - --- the individual modules - -MModule. ModDef ::= ComplMod ModType "=" ModBody ; - -MAbstract. ModType ::= "abstract" PIdent ; -MResource. ModType ::= "resource" PIdent ; -MGrammar. ModType ::= "grammar" PIdent ; -MInterface. ModType ::= "interface" PIdent ; -MConcrete. ModType ::= "concrete" PIdent "of" PIdent ; -MInstance. ModType ::= "instance" PIdent "of" PIdent ; - -MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; -MNoBody. ModBody ::= [Included] ; -MWith. ModBody ::= Included "with" [Open] ; -MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ; -MWithE. ModBody ::= [Included] "**" Included "with" [Open] ; -MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; - -MReuse. ModBody ::= "reuse" PIdent ; --% -MUnion. ModBody ::= "union" [Included] ;--% - -separator TopDef "" ; - -Ext. Extend ::= [Included] "**" ; -NoExt. Extend ::= ; - -separator Open "," ; -NoOpens. Opens ::= ; -OpenIn. Opens ::= "open" [Open] "in" ; - -OName. Open ::= PIdent ; --- OQualQO. Open ::= "(" PIdent ")" ; --% -OQual. Open ::= "(" PIdent "=" PIdent ")" ; - -CMCompl. ComplMod ::= ; -CMIncompl. ComplMod ::= "incomplete" ; - -separator Included "," ; - -IAll. Included ::= PIdent ; -ISome. Included ::= PIdent "[" [PIdent] "]" ; -IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; - --- top-level definitions - -DefCat. TopDef ::= "cat" [CatDef] ; -DefFun. TopDef ::= "fun" [FunDef] ; -DefFunData.TopDef ::= "data" [FunDef] ; -DefDef. TopDef ::= "def" [Def] ; -DefData. TopDef ::= "data" [DataDef] ; - -DefPar. TopDef ::= "param" [ParDef] ; -DefOper. TopDef ::= "oper" [Def] ; - -DefLincat. TopDef ::= "lincat" [Def] ; -DefLindef. TopDef ::= "lindef" [Def] ; -DefLin. TopDef ::= "lin" [Def] ; - -DefPrintCat. TopDef ::= "printname" "cat" [Def] ; -DefPrintFun. TopDef ::= "printname" "fun" [Def] ; -DefFlag. TopDef ::= "flags" [Def] ; - --- definitions after most keywords - -DDecl. Def ::= [Name] ":" Exp ; -DDef. Def ::= [Name] "=" Exp ; -DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list -DFull. Def ::= [Name] ":" Exp "=" Exp ; - -FDecl. FunDef ::= [Name] ":" Exp ; - -SimpleCatDef. CatDef ::= PIdent [DDecl] ; -ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; -ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; - -DataDef. DataDef ::= Name "=" [DataConstr] ; -DataId. DataConstr ::= PIdent ; -DataQId. DataConstr ::= PIdent "." PIdent ; -separator DataConstr "|" ; - -ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; -ParDefAbs. ParDef ::= PIdent ; - -ParConstr. ParConstr ::= PIdent [DDecl] ; - -terminator nonempty Def ";" ; -terminator nonempty FunDef ";" ; -terminator nonempty CatDef ";" ; -terminator nonempty DataDef ";" ; -terminator nonempty ParDef ";" ; - -separator ParConstr "|" ; - -separator nonempty PIdent "," ; - --- names of categories and functions in definition LHS - -PIdentName. Name ::= PIdent ; -ListName. Name ::= "[" PIdent "]" ; - -separator nonempty Name "," ; - --- definitions in records and $let$ expressions - -LDDecl. LocDef ::= [PIdent] ":" Exp ; -LDDef. LocDef ::= [PIdent] "=" Exp ; -LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ; - -separator LocDef ";" ; - --- terms and types - -EPIdent. Exp6 ::= PIdent ; -EConstr. Exp6 ::= "{" PIdent "}" ;--% -ECons. Exp6 ::= "%" PIdent "%" ;--% -ESort. Exp6 ::= Sort ; -EString. Exp6 ::= String ; -EInt. Exp6 ::= Integer ; -EFloat. Exp6 ::= Double ; -EMeta. Exp6 ::= "?" ; -EEmpty. Exp6 ::= "[" "]" ; -EData. Exp6 ::= "data" ; -EList. Exp6 ::= "[" PIdent Exps "]" ; -EStrings. Exp6 ::= "[" String "]" ; -ERecord. Exp6 ::= "{" [LocDef] "}" ; -- ! -ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator "," -EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --% -ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations - -EProj. Exp5 ::= Exp5 "." Label ; -EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --% -EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --% - -EApp. Exp4 ::= Exp4 Exp5 ; -ETable. Exp4 ::= "table" "{" [Case] "}" ; -ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ; -EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ; -ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ; -EVariants. Exp4 ::= "variants" "{" [Exp] "}" ; -EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; -EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; --% - -EPatt. Exp4 ::= "pattern" Patt2 ; -EPattType. Exp4 ::= "pattern" "type" Exp5 ; - -ESelect. Exp3 ::= Exp3 "!" Exp4 ; -ETupTyp. Exp3 ::= Exp3 "*" Exp4 ; -EExtend. Exp3 ::= Exp3 "**" Exp4 ; - -EGlue. Exp1 ::= Exp2 "+" Exp1 ; - -EConcat. Exp ::= Exp1 "++" Exp ; - -EAbstr. Exp ::= "\\" [Bind] "->" Exp ; -ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; -EProd. Exp ::= Decl "->" Exp ; -ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative -ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; -ELetb. Exp ::= "let" [LocDef] "in" Exp ; -EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ; -EEqs. Exp ::= "fn" "{" [Equation] "}" ; --% - -EExample. Exp ::= "in" Exp5 String ; - -coercions Exp 6 ; - -separator Exp ";" ; -- in variants - --- list of arguments to category -NilExp. Exps ::= ; -ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses - --- patterns - -PChar. Patt2 ::= "?" ; -PChars. Patt2 ::= "[" String "]" ; -PMacro. Patt2 ::= "#" PIdent ; -PM. Patt2 ::= "#" PIdent "." PIdent ; -PW. Patt2 ::= "_" ; -PV. Patt2 ::= PIdent ; -PCon. Patt2 ::= "{" PIdent "}" ; --% -PQ. Patt2 ::= PIdent "." PIdent ; -PInt. Patt2 ::= Integer ; -PFloat. Patt2 ::= Double ; -PStr. Patt2 ::= String ; -PR. Patt2 ::= "{" [PattAss] "}" ; -PTup. Patt2 ::= "<" [PattTupleComp] ">" ; -PC. Patt1 ::= PIdent [Patt] ; -PQC. Patt1 ::= PIdent "." PIdent [Patt] ; -PDisj. Patt ::= Patt "|" Patt1 ; -PSeq. Patt ::= Patt "+" Patt1 ; -PRep. Patt1 ::= Patt2 "*" ; -PAs. Patt1 ::= PIdent "@" Patt2 ; -PNeg. Patt1 ::= "-" Patt2 ; - -coercions Patt 2 ; - -PA. PattAss ::= [PIdent] "=" Patt ; - --- labels - -LPIdent. Label ::= PIdent ; -LVar. Label ::= "$" Integer ; - --- basic types - -rules Sort ::= - "Type" - | "PType" - | "Tok" --% - | "Str" - | "Strs" ; - -separator PattAss ";" ; - --- this is explicit to force higher precedence level on rhs -(:[]). [Patt] ::= Patt2 ; -(:). [Patt] ::= Patt2 [Patt] ; - - --- binds in lambdas and lin rules - -BPIdent. Bind ::= PIdent ; -BWild. Bind ::= "_" ; - -separator Bind "," ; - - --- declarations in function types - -DDec. Decl ::= "(" [Bind] ":" Exp ")" ; -DExp. Decl ::= Exp4 ; -- can thus be an application - --- tuple component (term or pattern) - -TComp. TupleComp ::= Exp ; -PTComp. PattTupleComp ::= Patt ; - -separator TupleComp "," ; -separator PattTupleComp "," ; - --- case branches - -Case. Case ::= Patt "=>" Exp ; - -separator nonempty Case ";" ; - --- cases in abstract syntax --% - -Equ. Equation ::= [Patt] "->" Exp ; --% - -separator Equation ";" ; --% - --- prefix alternatives - -Alt. Altern ::= Exp "/" Exp ; - -separator Altern ";" ; - --- in a context, higher precedence is required than in function types - -DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ; -DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application - -separator DDecl "" ; - - --------------------------------------- --% - --- for backward compatibility --% - -OldGr. OldGrammar ::= Include [TopDef] ; --% - -NoIncl. Include ::= ; --% -Incl. Include ::= "include" [FileName] ; --% - -FString. FileName ::= String ; --% - -terminator nonempty FileName ";" ; --% - -FPIdent. FileName ::= PIdent ; --% -FSlash. FileName ::= "/" FileName ; --% -FDot. FileName ::= "." FileName ; --% -FMinus. FileName ::= "-" FileName ; --% -FAddId. FileName ::= PIdent FileName ; --% - -token LString '\'' (char - '\'')* '\'' ; --% -ELString. Exp6 ::= LString ; --% -ELin. Exp4 ::= "Lin" PIdent ; --% - -DefPrintOld. TopDef ::= "printname" [Def] ; --% -DefLintype. TopDef ::= "lintype" [Def] ; --% -DefPattern. TopDef ::= "pattern" [Def] ; --% - --- deprecated packages are attempted to be interpreted --% -DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --% - --- these two are just ignored after parsing --% -DefVars. TopDef ::= "var" [Def] ; --% -DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --% diff --git a/src-3.0/GF/Devel/Compile/GFC.hs b/src-3.0/GF/Devel/Compile/GFC.hs deleted file mode 100644 index f60ec9380..000000000 --- a/src-3.0/GF/Devel/Compile/GFC.hs +++ /dev/null @@ -1,72 +0,0 @@ -module GF.Devel.Compile.GFC (mainGFC) where --- module Main where - -import GF.Devel.Compile.Compile -import GF.Devel.Compile.GFtoGFCC -import GF.Devel.PrintGFCC -import GF.GFCC.OptimizeGFCC -import GF.GFCC.CheckGFCC -import GF.GFCC.DataGFCC -import GF.GFCC.Raw.ParGFCCRaw -import GF.GFCC.Raw.ConvertGFCC -import GF.Devel.UseIO -import GF.Infra.Option -import GF.GFCC.API -import GF.Data.ErrM - -mainGFC :: [String] -> IO () -mainGFC xx = do - let (opts,fs) = getOptions "-" xx - case opts of - _ | oElem (iOpt "help") opts -> putStrLn usageMsg - _ | oElem (iOpt "-make") opts -> do - gr <- batchCompile opts fs - let name = justModuleName (last fs) - let (abs,gc0) = mkCanon2gfcc opts name gr - gc1 <- checkGFCCio gc0 - let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1 - let target = targetName opts abs - let gfccFile = target ++ ".gfcc" - writeFile gfccFile (printGFCC gc) - putStrLn $ "wrote file " ++ gfccFile - mapM_ (alsoPrint opts target gc) printOptions - - -- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc - _ | all ((==".gfcc") . takeExtensions) fs -> do - gfccs <- mapM file2gfcc fs - let gfcc = foldl1 unionGFCC gfccs - let abs = printCId $ absname gfcc - let target = targetName opts abs - let gfccFile = target ++ ".gfcc" - writeFile gfccFile (printGFCC gfcc) - putStrLn $ "wrote file " ++ gfccFile - mapM_ (alsoPrint opts target gfcc) printOptions - - _ -> do - mapM_ (batchCompile opts) (map return fs) - putStrLn "Done." - -targetName opts abs = case getOptVal opts (aOpt "target") of - Just n -> n - _ -> abs - ----- TODO: nicer and richer print options - -alsoPrint opts abs gr (opt,name) = do - if oElem (iOpt opt) opts - then do - let outfile = name - let output = prGFCC opt gr - writeFile outfile output - putStrLn $ "wrote file " ++ outfile - else return () - -printOptions = [ - ("haskell","GSyntax.hs"), - ("haskell_gadt","GSyntax.hs"), - ("js","grammar.js"), - ("jsref","grammarReference.js") - ] - -usageMsg = - "usage: gfc (-h | --make (-noopt) (-target=PREFIX) (-js | -jsref | -haskell | -haskell_gadt)) (-src) FILES" diff --git a/src-3.0/GF/Devel/Compile/GFtoGFCC.hs b/src-3.0/GF/Devel/Compile/GFtoGFCC.hs deleted file mode 100644 index 81f33e11a..000000000 --- a/src-3.0/GF/Devel/Compile/GFtoGFCC.hs +++ /dev/null @@ -1,542 +0,0 @@ -module GF.Devel.Compile.GFtoGFCC (prGrammar2gfcc,mkCanon2gfcc) where - -import GF.Devel.Compile.Factorize (unshareModule) - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import qualified GF.Devel.Grammar.Lookup as Look - -import qualified GF.Devel.Grammar.Grammar as A ---- -import qualified GF.Devel.Grammar.Grammar as M ---- -import qualified GF.Devel.Grammar.Macros as GM ---import qualified GF.Grammar.Compute as Compute - -import GF.Devel.Grammar.PrGF ---import GF.Devel.ModDeps -import GF.Infra.Ident - -import GF.Devel.PrintGFCC -import qualified GF.GFCC.Macros as CM -import qualified GF.GFCC.DataGFCC as C -import qualified GF.GFCC.DataGFCC as D -import GF.GFCC.CId -import GF.Infra.Option ---- -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List -import Data.Char (isDigit,isSpace) -import qualified Data.Map as Map -import Debug.Trace ---- - --- the main function: generate GFCC from GF. - -prGrammar2gfcc :: Options -> String -> GF -> (String,String) -prGrammar2gfcc opts cnc gr = (abs, printGFCC gc) where - (abs,gc) = mkCanon2gfcc opts cnc gr - -mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC) -mkCanon2gfcc opts cnc gr = - (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr) - where - abs = err error id $ Look.abstractOfConcrete gr (identC cnc) - pars = mkParamLincat gr - --- Generate GFCC from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> GF -> D.GFCC -canon2gfcc opts pars cgr = - (if (oElem (iOpt "show_canon") opts) then trace (prt cgr) else id) $ - D.GFCC an cns gflags abs cncs - where - -- recognize abstract and concretes - ([(a,abm)],cms) = - partition ((== MTAbstract) . mtype . snd) (Map.toList (gfmodules cgr)) - - -- abstract - an = (i2i a) - cns = map (i2i . fst) cms - abs = D.Abstr aflags funs cats catfuns - gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] - where fg = "firstlang" - aflags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)] - mkDef pty = case pty of - Meta _ -> CM.primNotion - t -> mkExp t - - funs = Map.fromAscList lfuns - cats = Map.fromAscList lcats - - lfuns = [(i2i f, (mkType (jtype ju), mkDef (jdef ju))) | - (f,ju) <- listJudgements abm, jform ju == JFun] - lcats = [(i2i c, mkContext (GM.contextOfType (jtype ju))) | - (c,ju) <- listJudgements abm, jform ju == JCat] - catfuns = Map.fromList - [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - - -- concretes - cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] - mkConcr lang0 lang mo = - (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) - where - js = listJudgements mo - flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)] - opers = Map.fromAscList [] -- opers will be created as optimization - utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ---- - then D.convertStringsInTerm decodeUTF8 else id - lins = Map.fromAscList - [(i2i f, utf (mkTerm (jdef ju))) | (f,ju) <- js, jform ju == JLin] - lincats = Map.fromAscList - [(i2i c, utf (mkTerm (jtype ju))) | (c,ju) <- js, jform ju == JLincat] - lindefs = Map.fromAscList - [(i2i c, utf (mkTerm (jdef ju))) | (c,ju) <- js, jform ju == JLincat] - printnames = Map.fromAscList - [(i2i c, utf (mkTerm (jprintname ju))) | - (c,ju) <- js, elem (jform ju) [JLincat,JLin]] - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ?? - fcfg = Nothing - -i2i :: Ident -> CId -i2i = CId . prIdent - -mkType :: A.Type -> C.Type -mkType t = case GM.typeForm t of - (hyps,(Q _ cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args) - -mkExp :: A.Term -> C.Exp -mkExp t = case t of - A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs] - _ -> case GM.termForm t of - (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args) - where - mkAt c = case c of - Q _ c -> C.AC $ i2i c - QC _ c -> C.AC $ i2i c - Vr x -> C.AV $ i2i x - EInt i -> C.AI i - EFloat f -> C.AF f - K s -> C.AS s - Meta i -> C.AM $ toInteger i - _ -> C.AM 0 - mkPatt p = uncurry CM.tree $ case p of - A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps) - A.PV x -> (C.AV (i2i x), []) - A.PW -> (C.AV CM.wildCId, []) - A.PInt i -> (C.AI i, []) - -mkContext :: A.Context -> [C.Hypo] -mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps] - -mkTerm :: Term -> C.Term -mkTerm tr = case tr of - Vr (IA (_,i)) -> C.V i - Vr (IC s) | isDigit (last s) -> - C.V (read (reverse (takeWhile (/='_') (reverse s)))) - ---- from gf parser of gfc - EInt i -> C.C $ fromInteger i - R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] - P t l -> C.P (mkTerm t) (C.C (mkLab l)) - T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ - V _ cs -> C.R [mkTerm t | t <- cs] - S t p -> C.P (mkTerm t) (mkTerm p) - C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] - FV ts -> C.FV [mkTerm t | t <- ts] - K s -> C.K (C.KS s) ------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants - Empty -> C.S [] - App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging - Abs _ t -> mkTerm t ---- only on toplevel - Alts (td,tvs) -> - C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (prt tr +++ "66662"))] ---- for debugging - where - mkLab (LIdent l) = case l of - '_':ds -> (read ds) :: Int - _ -> prtTrace tr $ 66663 - strings t = case t of - K s -> [s] - C u v -> strings u ++ strings v - FV ss -> concatMap strings ss - _ -> prtTrace tr $ ["66660"] - flats t = case t of - C.S ts -> concatMap flats ts - _ -> [t] - --- encoding GFCC-internal lincats as terms -mkCType :: Type -> C.Term -mkCType t = case t of - EInt i -> C.C $ fromInteger i - RecType rs -> C.R [mkCType t | (_, t) <- rs] - Table pt vt -> case pt of - EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt - RecType rs -> mkCType $ foldr Table vt (map snd rs) - Sort "Str" -> C.S [] --- Str only - App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i - _ -> error $ "mkCType " ++ show t - --- encoding showable lincats (as in source gf) as terms -mkParamLincat :: GF -> Ident -> Ident -> C.Term -mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do - typ <- Look.lookupLincat sgr lang cat - mkPType typ - where - mkPType typ = case typ of - RecType lts -> do - ts <- mapM (mkPType . snd) lts - return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts] - Table (RecType lts) v -> do - ps <- mapM (mkPType . snd) lts - v' <- mkPType v - return $ foldr (\p v -> C.S [p,v]) v' ps - Table p v -> do - p' <- mkPType p - v' <- mkPType v - return $ C.S [p',v'] - Sort "Str" -> return $ C.S [] - _ -> return $ - C.FV $ map (kks . filter showable . prt_) $ - errVal [] $ Look.allParamValues sgr typ - showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records - kks = C.K . C.KS - --- return just one module per language - -reorder :: Ident -> GF -> GF -reorder abs cg = emptyGF { - gfabsname = Just abs, - gfcncnames = (map fst cncs), - gfmodules = Map.fromList ((abs,absm) : map mkCnc cncs) - } - where - absm = emptyModule { - mtype = MTAbstract, - mflags = aflags, - mjments = adefs - } - mkCnc (c,cnc) = (c,emptyModule { - mtype = MTConcrete abs, - mflags = fst cnc, - mjments = snd cnc - }) - - mos = Map.toList $ gfmodules cg - - adefs = Map.fromAscList $ sortIds $ - predefADefs ++ Look.allOrigJudgements cg abs - predefADefs = - [(IC c, absCat []) | c <- ["Float","Int","String"]] - aflags = Map.fromList $ nubByFst $ concat - [Map.toList (M.mflags mo) | (_,mo) <- mos, mtype mo == MTAbstract] ----toom - - cncs = sortIds [(lang, concr lang) | lang <- Look.allConcretes cg abs] - concr la = ( - Map.fromList (nubByFst flags), - Map.fromList (sortIds (predefCDefs ++ jments)) - ) where - jments = Look.allOrigJudgements cg la - flags = Look.lookupFlags cg la - ----concat [M.mflags mo | - ---- (i,mo) <- mos, M.isModCnc mo, - ---- Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = [(IC c, cncCat GM.defLinType) | - ---- lindef,printname - c <- ["Float","Int","String"]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare f g) - -nubByFst = nubBy (\ (f,_) (g,_) -> f == g) - - --- one grammar per language - needed for symtab generation -repartition :: Ident -> GF -> [GF] -repartition abs cg = [Look.partOfGrammar cg (lang,mo) | - let mos = gfmodules cg, - lang <- Look.allConcretes cg abs, - let mo = errVal - (error ("no module found for " ++ prt lang)) $ Look.lookupModule cg lang - ] - - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Ident -> GF -> GF -canon2canon abs gf = errVal gf $ GM.termOpGF t2t gf where - t2t = return . term2term gf pv - ty2ty = type2type gf pv - pv@(labels,untyps,typs) = paramValues gf - ---- should be done lang for lang - ---- ty2ty should be used for types, t2t only in concrete - -{- ---- - gfModules . nubModules . map cl2cl . repartition abs . purgeGrammar abs - where - nubModules = Map.fromList . nubByFst . concatMap (Map.toList . gfmodules) - - cl2cl gf = errVal gf $ GM.moduleOpGF (js2js . map (GM.judgementOpModule p2p)) gf - - js2js ms = map (GM.judgementOpModule (j2j (gfModules ms))) ms - - j2j cg (f,j) = case jform j of - JLin -> (f, j{jdef = t2t (jdef j)}) - JLincat -> (f, j{jdef = t2t (jdef j), jtype = ty2ty (jtype j)}) - _ -> (f,j) - where - t2t = term2term cg pv - ty2ty = type2type cg pv - pv@(labels,untyps,typs) = paramValues cg ---trs $ paramValues cg - - -- flatten record arguments of param constructors - p2p (f,j) = case jform j of - ---- JParam -> - ----ResParam (Yes (ps,v)) -> - ----(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))) - _ -> (f,j) - unRec (x,ty) = case ty of - RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] - _ -> [(x,ty)] - ----- - trs v = trace (tr v) v - - tr (labels,untyps,typs) = - ("labels:" ++++ - unlines [prt c ++ "." ++ unwords (map prt l) +++ "=" +++ show i | - ((c,l),i) <- Map.toList labels]) ++ - ("untyps:" ++++ unlines [prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) ++ - ("typs:" ++++ unlines [prt t | - (t,_) <- Map.toList typs]) ----- --} - -purgeGrammar :: Ident -> GF -> GF -purgeGrammar abstr gr = gr { - gfmodules = treat gr - } - where - treat = - Map.fromList . map unopt . filter complete . purge . Map.toList . gfmodules - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - needed = - nub $ concatMap (Look.allDepsModule gr) $ - ---- (requiredCanModules True gr) $ - [mo | m <- abstr : Look.allConcretes gr abstr, - Ok mo <- [Look.lookupModule gr m]] - - complete (i,mo) = isCompleteModule mo - unopt = unshareModule gr -- subexp elim undone when compiled - -type ParamEnv = - (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map Type (Map.Map Term Integer)) -- types to their terms to values - ---- gathers those param types that are actually used in lincats and lin terms -paramValues :: GF -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - - jments = [(m,j) | - (m,mo) <- Map.toList (gfmodules cgr), - j <- Map.toList (mjments mo)] - - partyps = nub $ [ty | - (_,(_,ju)) <- jments, - jform ju == JLincat, - RecType ls <- [jtype ju], - ty0 <- [ty | (_, ty) <- unlockTyp ls], - ty <- typsFrom ty0 - ] ++ [Q m ty | - (m,(ty,ju)) <- jments, - jform ju == JParam - ] ++ [ty | - (_,(_,ju)) <- jments, - jform ju == JLin, - ty <- err (const []) snd $ appSTM (typsFromTrm (jdef ju)) [] - ] - params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps] - typsFrom ty = case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls] - _ -> [ty] - - typsFromTrm :: Term -> STM [Type] Term - typsFromTrm tr = case tr of - R fs -> mapM_ (typsFromField . snd) fs >> return tr - where - typsFromField (mty, t) = case mty of - Just x -> updateSTM (x:) >> typsFromTrm t - _ -> typsFromTrm t - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr - T (TTyped ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - T (TComp ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - _ -> GM.composOp typsFromTrm tr - - typs = - Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] - untyps = - Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] - lincats = - [(IC cat,[(LIdent "s",typeStr)]) | cat <- ["Int", "Float", "String"]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,(unlockTyp ls)) | - (_,(cat,ju)) <- jments, - jform ju == JLincat, - RecType ls <- [jtype ju] - ] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]] - -- go to tables recursively - ---- TODO: even go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] - Table _ t -> getRec t - _ -> [] - -type2type :: GF -> ParamEnv -> Type -> Type -type2type cgr env@(labels,untyps,typs) ty = case ty of - RecType rs -> - RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] - Table pt vt -> Table (t2t pt) (t2t vt) - QC _ _ -> look ty - _ -> ty - where - t2t = type2type cgr env - look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of - Just vs -> length $ Map.assocs vs - _ -> trace ("unknown partype " ++ show ty) 66669 - -term2term :: GF -> ParamEnv -> Term -> Term -term2term cgr env@(labels,untyps,typs) tr = case tr of - App _ _ -> mkValCase (unrec tr) - QC _ _ -> mkValCase tr - R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] - P t l -> r2r tr - PI t l i -> EInt $ toInteger i - T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - V ty ts -> mkCurry $ V ty [t2t t | t <- ts] - S t p -> mkCurrySel (t2t t) (t2t p) - _ -> GM.composSafeOp t2t tr - where - t2t = term2term cgr env - - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum $ comp tr - - --- this is mainly needed for parameter record projections - ---- was: errVal t $ Compute.computeConcreteRec cgr t - comp t = case t of - T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should... - T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should - V typ ts -> V typ (map comp ts) - S (V typ ts) v0 -> err error id $ do - let v = comp v0 - return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps - R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r] - P (R r) l -> maybe t (comp . snd) $ lookup l r - _ -> GM.composSafeOp comp t - - doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term - doVar tr = case getLab tr of - Ok (cat, lab) -> do - k <- readSTM >>= return . length - let tr' = Vr $ identC $ show k ----- - - let tyvs = case Map.lookup (cat,lab) labels of - Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,[t | - (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) - (Map.assocs vs)]) - _ -> error $ prt ty - _ -> error $ prt tr - updateSTM ((tyvs, (tr', tr)):) - return tr' - _ -> GM.composOp doVar tr - - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K ((prt tr +++ prtTrace tr "66665")) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA (cat, _)) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser ----- Vr _ -> error $ "getLab " ++ show tr - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" - - - mkCase ((ty,vs),(x,p)) tr = - S (V ty [mkBranch x v tr | v <- vs]) p - mkBranch x t tr = case tr of - _ | tr == x -> t - _ -> GM.composSafeOp (mkBranch x t) tr - - valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps - where - tryFV tr = case GM.appForm tr of - (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] - (FV ts,_) -> ts - _ -> [tr] - valNumFV ts = case ts of - [tr] -> trace (unwords (map prt (Map.keys typs))) $ - prtTrace tr $ K "66667" - _ -> FV $ map valNum ts - - mkCurry trm = case trm of - V (RecType [(_,ty)]) ts -> V ty ts - V (RecType ((_,ty):ltys)) ts -> - V ty [mkCurry (V (RecType ltys) cs) | - cs <- chop (product (map (lengthtyp . snd) ltys)) ts] - _ -> trm - lengthtyp ty = case Map.lookup ty typs of - Just m -> length (Map.assocs m) - _ -> error $ "length of type " ++ show ty - chop i xs = case splitAt i xs of - (xs1,[]) -> [xs1] - (xs1,xs2) -> xs1:chop i xs2 - - - mkCurrySel t p = S t p -- done properly in CheckGFCC - - -mkLab k = LIdent (("_" ++ show k)) - --- remove lock fields; in fact, any empty records and record types -unlock = filter notlock where - notlock (l,(_, t)) = case t of --- need not look at l - R [] -> False - _ -> True -unlockTyp = filter notlock where - notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - -prtTrace tr n = - trace ("-- INTERNAL COMPILER ERROR" +++ prt tr ++++ show n) n -prTrace tr n = trace ("-- OBSERVE" +++ prt tr +++ show n +++ show tr) n - diff --git a/src-3.0/GF/Devel/Compile/GetGrammar.hs b/src-3.0/GF/Devel/Compile/GetGrammar.hs deleted file mode 100644 index b90bd912c..000000000 --- a/src-3.0/GF/Devel/Compile/GetGrammar.hs +++ /dev/null @@ -1,56 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- this module builds the internal GF grammar that is sent to the type checker ------------------------------------------------------------------------------ - -module GF.Devel.Compile.GetGrammar where - -import GF.Devel.UseIO -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -----import GF.Devel.PrGrammar -import GF.Devel.Compile.SourceToGF ----- import Macros ----- import Rename ---- import Custom -import GF.Devel.Compile.ParGF -import qualified GF.Devel.Compile.LexGF as L - -import GF.Data.Operations -import qualified GF.Devel.Compile.ErrM as E ---- -import GF.Infra.Option ---- -import GF.Devel.ReadFiles ---- - -import Data.Char (toUpper) -import Data.List (nub) -import Control.Monad (foldM) -import System (system) - -getSourceModule :: Options -> FilePath -> IOE SourceModule -getSourceModule opts file0 = do - file <- case getOptVal opts usePreprocessor of - Just p -> do - let tmp = "_gf_preproc.tmp" - cmd = p +++ file0 ++ ">" ++ tmp - ioeIO $ system cmd - -- ioeIO $ putStrLn $ "preproc" +++ cmd - return tmp - _ -> return file0 - string <- readFileIOE file - let tokens = myLexer string - mo1 <- ioeErr $ err2err $ pModDef tokens - ioeErr $ transModDef mo1 - -err2err e = case e of - E.Ok v -> Ok v - E.Bad s -> Bad s - diff --git a/src-3.0/GF/Devel/Compile/LexGF.hs b/src-3.0/GF/Devel/Compile/LexGF.hs deleted file mode 100644 index ff8386f49..000000000 --- a/src-3.0/GF/Devel/Compile/LexGF.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "GF/Devel/Compile/LexGF.x" #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Devel.Compile.LexGF where - - - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#else -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x27\x00\x00\x00\x13\x00\x00\x00\x9c\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\x00\x00\x0c\x03\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xe7\x01\x00\x00\xd5\x00\x00\x00\x35\x00\x00\x00\xe7\x00\x00\x00\xf2\x00\x00\x00\x1d\x01\x00\x00\xc2\x01\x00\x00\xcc\x01\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x1a\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x17\x00\x0e\x00\x0e\x00\x0f\x00\x10\x00\x0e\x00\x05\x00\x0e\x00\x0e\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x04\x00\xff\xff\xff\xff\x02\x00\x02\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\x0e\x00\x0e\x00\x16\x00\x16\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x12\x00\xff\xff\x0d\x00\x20\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x09\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0e\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\x07\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1b\x00\xff\xff\x00\x00\x00\x00\x14\x00\x1b\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1c\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x1c\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x3e\x00\x2b\x00\x27\x00\x27\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x7d\x00\x7d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xf7\x00\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x13\x00\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x0b\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x18\x00\xff\xff\x1b\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,34) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_7))],[],[],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[],[],[]] -{-# LINE 36 "GF/Devel/Compile/LexGF.x" #-} - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words and symbols - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - | T_PIdent !String - | T_LString !String - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - PT _ (T_PIdent s) -> s - PT _ (T_LString s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "lin" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "let" N N)))) (b "resource" (b "oper" (b "lintype" (b "lindef" (b "lincat" N N) N) (b "open" (b "of" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "type" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N)))) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> [Err pos] - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c - -alex_action_3 = tok (\p s -> PT p (TS $ share s)) -alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) -alex_action_5 = tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) -alex_action_6 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_7 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) -alex_action_8 = tok (\p s -> PT p (TI $ share s)) -alex_action_9 = tok (\p s -> PT p (TD $ share s)) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -{-# LINE 35 "GenericTemplate.hs" #-} - -{-# LINE 45 "GenericTemplate.hs" #-} - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user orig_input (len +# 1#) - new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src-3.0/GF/Devel/Compile/Optimize.hs b/src-3.0/GF/Devel/Compile/Optimize.hs deleted file mode 100644 index 746b47b90..000000000 --- a/src-3.0/GF/Devel/Compile/Optimize.hs +++ /dev/null @@ -1,333 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Optimize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/16 13:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- Top-level partial evaluation for GF source modules. ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Optimize (optimizeModule) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros ---import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.Compute - ---import GF.Infra.Ident - -import GF.Devel.Grammar.Lookup ---import GF.Grammar.Refresh - ---import GF.Compile.BackOpt -import GF.Devel.Compile.CheckGrammar ---import GF.Compile.Update - - ---import GF.Infra.CheckM -import GF.Infra.Option ---- - -import GF.Data.Operations - -import Control.Monad -import Data.List -import qualified Data.Map as Map - -import Debug.Trace - - -optimizeModule :: Options -> GF -> SourceModule -> Err SourceModule -optimizeModule opts gf0 sm@(m,mo) = case mtype mo of - MTConcrete _ -> opt sm - MTInstance _ -> optr sm - MTGrammar -> optr sm - _ -> return sm - where - gf = gf0 {gfmodules = Map.insert m mo (gfmodules gf0)} - opt (m,mo) = do - mo' <- termOpModule (computeTerm gf) mo - return (m,mo') - - optr (m,mo)= do - let deps = allOperDependencies m $ mjments mo - ids <- topoSortOpers deps - gf' <- foldM evalOp gf ids - mo' <- lookupModule gf' m - return $ (m,mo') - where - evalOp gf i = do - ju <- lookupJudgement gf m i - def' <- computeTerm gf (jdef ju) - updateJudgement m i (ju {jdef = def'}) gf - - - - -{- - --- conditional trace - -prtIf :: (Print a) => Bool -> a -> a -prtIf b t = if b then trace (" " ++ prt t) t else t - --- | partial evaluation of concrete syntax. --- AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005 -- 7/12/2007 - -type EEnv = () --- not used - --- only do this for resource: concrete is optimized in gfc form - - - - =mse@(ms,eenv) mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | - st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do - (mo1,_) <- evalModule oopts mse mo - let - mo2 = case optim of - "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing - "values" -> shareModule valOpt mo1 -- tables as courses-of-values - "share" -> shareModule shareOpt mo1 -- sharing of branches - "all" -> shareModule allOpt mo1 -- first parametrize then values - "none" -> mo1 -- no optimization - _ -> mo1 -- none; default for src - return (mo2,eenv) - _ -> evalModule oopts mse mo - where - oopts = addOptions opts (iOpts (flagsModule mo)) - optim = maybe "all" id $ getOptVal oopts useOptimizer - -evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> - Err ((Ident,SourceModInfo),EEnv) -evalModule oopts (ms,eenv) mo@(name,mod) = case mod of - - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of - _ | isModRes m0 && not (oElem oEval oopts) -> do - let deps = allOperDependencies name js - ids <- topoSortOpers deps - MGrammar (mod' : _) <- foldM evalOp gr ids - return $ (mod',eenv) - - MTConcrete a -> do - js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),eenv) - - _ -> return $ ((name,mod),eenv) - _ -> return $ ((name,mod),eenv) - where - gr0 = MGrammar $ ms - gr = MGrammar $ (name,mod) : ms - - evalOp g@(MGrammar ((_, ModMod m) : _)) i = do - info <- lookupTree prt i $ jments m - info' <- evalResInfo oopts gr (i,info) - return $ updateRes g name i info' - --- | only operations need be compiled in a resource, and this is local to each --- definition since the module is traversed in topological order -evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info -evalResInfo oopts gr (c,info) = case info of - - ResOper pty pde -> eIn "operation" $ do - pde' <- case pde of - Yes de | optres -> liftM yes $ comp de - _ -> return pde - return $ ResOper pty pde' - - _ -> return info - where - comp = if optres then computeConcrete gr else computeConcreteRec gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - optim = maybe "all" id $ getOptVal oopts useOptimizer - optres = case optim of - "noexpand" -> False - _ -> True - - -evalCncInfo :: - Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) -evalCncInfo opts gr cnc abs (c,info) = do - - seq (prtIf (oElem beVerbose opts) c) $ return () - - errIn ("optimizing" +++ prt c) $ case info of - - CncCat ptyp pde ppr -> do - pde' <- case (ptyp,pde) of - (Yes typ, Yes de) -> - liftM yes $ pEval ([(strVar, typeStr)], typ) de - (Yes typ, Nope) -> - liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ) - (May b, Nope) -> - return $ May b - _ -> return pde -- indirection - - ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) - - return (c, CncCat ptyp pde' ppr') - - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do - pde' <- case pde of - Yes de | notNewEval -> do - liftM yes $ pEval ty de - - _ -> return pde - ppr' <- liftM yes $ evalPrintname gr c ppr pde' - return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed - - _ -> return (c,info) - where - pEval = partEval opts gr - eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - notNewEval = not (oElem oEval opts) - --- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do - let vars = map fst context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm3 <- if globalTable - then etaExpand subst trm1 >>= outCase subst - else etaExpand subst trm1 - return $ mkAbs vars trm3 - - where - - globalTable = oElem showAll opts --- i -all - - comp g t = ---- refreshTerm t >>= - computeTerm gr g t - - etaExpand su t = do - t' <- comp su t - case t' of - R _ | rightType t' -> comp su t' --- return t' wo noexpand... - _ -> recordExpand val t' >>= comp su - -- don't eta expand records of right length (correct by type checking) - rightType t = case (t,val) of - (R rs, RecType ts) -> length rs == length ts - _ -> False - - outCase subst t = do - pts <- getParams context - let (args,ptyps) = unzip $ filter (flip occur t . fst) pts - if null args - then return t - else do - let argtyp = RecType $ tuple2recordType ptyps - let pvars = map (Vr . zIdent . prt) args -- gets eliminated - patt <- term2patt $ R $ tuple2record $ pvars - let t' = replace (zip args pvars) t - t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] - return $ S t1 $ R $ tuple2record args - - --- notice: this assumes that all lin types follow the "old JFP style" - getParams = liftM concat . mapM getParam - getParam (argv,RecType rs) = return - [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] - ---getParam (_,ty) | ty==typeStr = return [] --- in lindef - getParam (av,ty) = - Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) - --- all lin types are rec types - - replace :: [(Term,Term)] -> Term -> Term - replace reps trm = case trm of - -- this is the important case - P _ _ -> maybe trm id $ lookup trm reps - _ -> composSafeOp (replace reps) trm - - occur t trm = case trm of - - -- this is the important case - P _ _ -> t == trm - S x y -> occur t y || occur t x - App f x -> occur t x || occur t f - Abs _ f -> occur t f - R rs -> any (occur t) (map (snd . snd) rs) - T _ cs -> any (occur t) (map snd cs) - C x y -> occur t x || occur t y - Glue x y -> occur t x || occur t y - ExtR x y -> occur t x || occur t y - FV ts -> any (occur t) ts - V _ ts -> any (occur t) ts - Let (_,(_,x)) y -> occur t x || occur t y - _ -> False - - --- here we must be careful not to reduce --- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} --- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; - -recordExpand :: Type -> Term -> Err Term -recordExpand typ trm = case unComputed typ of - RecType tys -> case trm of - FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] - _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] - _ -> return trm - - --- | auxiliaries for compiling the resource - -mkLinDefault :: SourceGrammar -> Type -> Err Term -mkLinDefault gr typ = do - case unComputed typ of - RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) - _ -> prtBad "linearization type must be a record type, not" typ - where - mkDefField typ = case unComputed typ of - Table p t -> do - t' <- mkDefField t - let T _ cs = mkWildCases t' - return $ T (TWild p) cs - Sort "Str" -> return $ Vr strVar - QC q p -> lookupFirstTag gr q p - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM mkDefField ts - return $ R $ [assign l t | (l,t) <- zip ls ts'] - _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> prtBad "linearization type field cannot be" typ - --- | Form the printname: if given, compute. If not, use the computed --- lin for functions, cat name for cats (dispatch made in evalCncDef above). ---- We cannot use linearization at this stage, since we do not know the ---- defaults we would need for question marks - and we're not yet in canon. -evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term -evalPrintname gr c ppr lin = - case ppr of - Yes pr -> comp pr - _ -> case lin of - Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm - _ -> return $ K $ prt c ---- - where - comp = computeConcrete gr - - oneBranch t = case t of - Abs _ b -> oneBranch b - R (r:_) -> oneBranch $ snd $ snd r - T _ (c:_) -> oneBranch $ snd c - V _ (c:_) -> oneBranch c - FV (t:_) -> oneBranch t - C x y -> C (oneBranch x) (oneBranch y) - S x _ -> oneBranch x - P x _ -> oneBranch x - Alts (d,_) -> oneBranch d - _ -> t - - --- very unclean cleaner - clean s = case s of - '+':'+':' ':cs -> clean cs - '"':cs -> clean cs - c:cs -> c: clean cs - _ -> s - --} diff --git a/src-3.0/GF/Devel/Compile/ParGF.hs b/src-3.0/GF/Devel/Compile/ParGF.hs deleted file mode 100644 index ce474e418..000000000 --- a/src-3.0/GF/Devel/Compile/ParGF.hs +++ /dev/null @@ -1,3210 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module GF.Devel.Compile.ParGF where -import GF.Devel.Compile.AbsGF -import GF.Devel.Compile.LexGF -import GF.Devel.Compile.ErrM -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.16 - -newtype HappyAbsSyn = HappyAbsSyn (() -> ()) -happyIn7 :: (Integer) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (Integer) -happyOut7 x = unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (String) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (String) -happyOut8 x = unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Double) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Double) -happyOut9 x = unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (PIdent) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (PIdent) -happyOut10 x = unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (LString) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (LString) -happyOut11 x = unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Grammar) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Grammar) -happyOut12 x = unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: ([ModDef]) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> ([ModDef]) -happyOut13 x = unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (ModDef) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (ModDef) -happyOut14 x = unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (ModType) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (ModType) -happyOut15 x = unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (ModBody) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (ModBody) -happyOut16 x = unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([TopDef]) -> (HappyAbsSyn ) -happyIn17 x = unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([TopDef]) -happyOut17 x = unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Extend) -> (HappyAbsSyn ) -happyIn18 x = unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (Extend) -happyOut18 x = unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([Open]) -> (HappyAbsSyn ) -happyIn19 x = unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> ([Open]) -happyOut19 x = unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (Opens) -> (HappyAbsSyn ) -happyIn20 x = unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Opens) -happyOut20 x = unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (Open) -> (HappyAbsSyn ) -happyIn21 x = unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (Open) -happyOut21 x = unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (ComplMod) -> (HappyAbsSyn ) -happyIn22 x = unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (ComplMod) -happyOut22 x = unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: ([Included]) -> (HappyAbsSyn ) -happyIn23 x = unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> ([Included]) -happyOut23 x = unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (Included) -> (HappyAbsSyn ) -happyIn24 x = unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Included) -happyOut24 x = unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (TopDef) -> (HappyAbsSyn ) -happyIn25 x = unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (TopDef) -happyOut25 x = unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Def) -> (HappyAbsSyn ) -happyIn26 x = unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Def) -happyOut26 x = unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (FunDef) -> (HappyAbsSyn ) -happyIn27 x = unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (FunDef) -happyOut27 x = unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (CatDef) -> (HappyAbsSyn ) -happyIn28 x = unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (CatDef) -happyOut28 x = unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: (DataDef) -> (HappyAbsSyn ) -happyIn29 x = unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (DataDef) -happyOut29 x = unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (DataConstr) -> (HappyAbsSyn ) -happyIn30 x = unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (DataConstr) -happyOut30 x = unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: ([DataConstr]) -> (HappyAbsSyn ) -happyIn31 x = unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> ([DataConstr]) -happyOut31 x = unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (ParDef) -> (HappyAbsSyn ) -happyIn32 x = unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (ParDef) -happyOut32 x = unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (ParConstr) -> (HappyAbsSyn ) -happyIn33 x = unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (ParConstr) -happyOut33 x = unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: ([Def]) -> (HappyAbsSyn ) -happyIn34 x = unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> ([Def]) -happyOut34 x = unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: ([FunDef]) -> (HappyAbsSyn ) -happyIn35 x = unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> ([FunDef]) -happyOut35 x = unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: ([CatDef]) -> (HappyAbsSyn ) -happyIn36 x = unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> ([CatDef]) -happyOut36 x = unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: ([DataDef]) -> (HappyAbsSyn ) -happyIn37 x = unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> ([DataDef]) -happyOut37 x = unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: ([ParDef]) -> (HappyAbsSyn ) -happyIn38 x = unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> ([ParDef]) -happyOut38 x = unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: ([ParConstr]) -> (HappyAbsSyn ) -happyIn39 x = unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> ([ParConstr]) -happyOut39 x = unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: ([PIdent]) -> (HappyAbsSyn ) -happyIn40 x = unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> ([PIdent]) -happyOut40 x = unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: (Name) -> (HappyAbsSyn ) -happyIn41 x = unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (Name) -happyOut41 x = unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: ([Name]) -> (HappyAbsSyn ) -happyIn42 x = unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> ([Name]) -happyOut42 x = unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: (LocDef) -> (HappyAbsSyn ) -happyIn43 x = unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> (LocDef) -happyOut43 x = unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: ([LocDef]) -> (HappyAbsSyn ) -happyIn44 x = unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> ([LocDef]) -happyOut44 x = unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: (Exp) -> (HappyAbsSyn ) -happyIn45 x = unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> (Exp) -happyOut45 x = unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: (Exp) -> (HappyAbsSyn ) -happyIn46 x = unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> (Exp) -happyOut46 x = unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: (Exp) -> (HappyAbsSyn ) -happyIn47 x = unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> (Exp) -happyOut47 x = unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (Exp) -> (HappyAbsSyn ) -happyIn48 x = unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (Exp) -happyOut48 x = unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (Exp) -> (HappyAbsSyn ) -happyIn49 x = unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (Exp) -happyOut49 x = unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (Exp) -> (HappyAbsSyn ) -happyIn50 x = unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (Exp) -happyOut50 x = unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (Exp) -> (HappyAbsSyn ) -happyIn51 x = unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> (Exp) -happyOut51 x = unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: ([Exp]) -> (HappyAbsSyn ) -happyIn52 x = unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> ([Exp]) -happyOut52 x = unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: (Exps) -> (HappyAbsSyn ) -happyIn53 x = unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> (Exps) -happyOut53 x = unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: (Patt) -> (HappyAbsSyn ) -happyIn54 x = unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> (Patt) -happyOut54 x = unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: (Patt) -> (HappyAbsSyn ) -happyIn55 x = unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> (Patt) -happyOut55 x = unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: (Patt) -> (HappyAbsSyn ) -happyIn56 x = unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> (Patt) -happyOut56 x = unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: (PattAss) -> (HappyAbsSyn ) -happyIn57 x = unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> (PattAss) -happyOut57 x = unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: (Label) -> (HappyAbsSyn ) -happyIn58 x = unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> (Label) -happyOut58 x = unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: (Sort) -> (HappyAbsSyn ) -happyIn59 x = unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> (Sort) -happyOut59 x = unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: ([PattAss]) -> (HappyAbsSyn ) -happyIn60 x = unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn ) -> ([PattAss]) -happyOut60 x = unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: ([Patt]) -> (HappyAbsSyn ) -happyIn61 x = unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn ) -> ([Patt]) -happyOut61 x = unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: (Bind) -> (HappyAbsSyn ) -happyIn62 x = unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn ) -> (Bind) -happyOut62 x = unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: ([Bind]) -> (HappyAbsSyn ) -happyIn63 x = unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn ) -> ([Bind]) -happyOut63 x = unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: (Decl) -> (HappyAbsSyn ) -happyIn64 x = unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn ) -> (Decl) -happyOut64 x = unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: (TupleComp) -> (HappyAbsSyn ) -happyIn65 x = unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn ) -> (TupleComp) -happyOut65 x = unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: (PattTupleComp) -> (HappyAbsSyn ) -happyIn66 x = unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn ) -> (PattTupleComp) -happyOut66 x = unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: ([TupleComp]) -> (HappyAbsSyn ) -happyIn67 x = unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn ) -> ([TupleComp]) -happyOut67 x = unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: ([PattTupleComp]) -> (HappyAbsSyn ) -happyIn68 x = unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn ) -> ([PattTupleComp]) -happyOut68 x = unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: (Case) -> (HappyAbsSyn ) -happyIn69 x = unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn ) -> (Case) -happyOut69 x = unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: ([Case]) -> (HappyAbsSyn ) -happyIn70 x = unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn ) -> ([Case]) -happyOut70 x = unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: (Equation) -> (HappyAbsSyn ) -happyIn71 x = unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn ) -> (Equation) -happyOut71 x = unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyIn72 :: ([Equation]) -> (HappyAbsSyn ) -happyIn72 x = unsafeCoerce# x -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn ) -> ([Equation]) -happyOut72 x = unsafeCoerce# x -{-# INLINE happyOut72 #-} -happyIn73 :: (Altern) -> (HappyAbsSyn ) -happyIn73 x = unsafeCoerce# x -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn ) -> (Altern) -happyOut73 x = unsafeCoerce# x -{-# INLINE happyOut73 #-} -happyIn74 :: ([Altern]) -> (HappyAbsSyn ) -happyIn74 x = unsafeCoerce# x -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn ) -> ([Altern]) -happyOut74 x = unsafeCoerce# x -{-# INLINE happyOut74 #-} -happyIn75 :: (DDecl) -> (HappyAbsSyn ) -happyIn75 x = unsafeCoerce# x -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn ) -> (DDecl) -happyOut75 x = unsafeCoerce# x -{-# INLINE happyOut75 #-} -happyIn76 :: ([DDecl]) -> (HappyAbsSyn ) -happyIn76 x = unsafeCoerce# x -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn ) -> ([DDecl]) -happyOut76 x = unsafeCoerce# x -{-# INLINE happyOut76 #-} -happyIn77 :: (OldGrammar) -> (HappyAbsSyn ) -happyIn77 x = unsafeCoerce# x -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn ) -> (OldGrammar) -happyOut77 x = unsafeCoerce# x -{-# INLINE happyOut77 #-} -happyIn78 :: (Include) -> (HappyAbsSyn ) -happyIn78 x = unsafeCoerce# x -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn ) -> (Include) -happyOut78 x = unsafeCoerce# x -{-# INLINE happyOut78 #-} -happyIn79 :: (FileName) -> (HappyAbsSyn ) -happyIn79 x = unsafeCoerce# x -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn ) -> (FileName) -happyOut79 x = unsafeCoerce# x -{-# INLINE happyOut79 #-} -happyIn80 :: ([FileName]) -> (HappyAbsSyn ) -happyIn80 x = unsafeCoerce# x -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn ) -> ([FileName]) -happyOut80 x = unsafeCoerce# x -{-# INLINE happyOut80 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x00\x00\x34\x04\x2a\x04\xe9\x00\x0d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x04\x90\x01\x6f\x00\x37\x04\xfa\x03\x35\x04\x00\x00\x31\x04\xe7\x03\xfe\xff\x1c\x00\xe7\x03\x00\x00\xe9\x00\x29\x00\xe7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x30\x04\x63\x02\x06\x00\x00\x03\x2f\x04\x2e\x04\x58\x02\x2d\x04\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x03\x00\x00\xf9\xff\x01\x00\x6e\x08\x00\x00\xdc\x03\x4e\x00\x2c\x04\x1c\x04\xc6\x03\xc6\x03\xc6\x03\xc6\x03\xc6\x03\xc6\x03\x00\x00\x00\x00\xf9\xff\x13\x04\x00\x00\xf9\xff\xf9\xff\xf9\xff\xf6\x07\xe9\x00\x17\x01\xeb\x02\x9b\x00\xc4\x03\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x03\x04\x00\x00\xc3\x03\xeb\x02\xc1\x03\x00\x00\xeb\x02\xc0\x03\x00\x00\x0a\x02\x06\x04\x39\x00\x0a\x04\xdb\x03\xb1\x03\x1b\x00\x16\x03\xd4\x03\x00\x00\x00\x00\xf3\x03\xdf\x03\x77\x00\x00\x00\xee\x03\xf0\x03\xe2\x03\x43\x02\xeb\x03\xff\x01\x00\x00\xd6\x00\xea\x03\xe5\x03\xf4\x01\x8d\x02\xe8\x03\x4d\x00\x37\x01\x4d\x00\x37\x01\x37\x01\x37\x01\x4d\x00\xe1\x03\xd6\x03\xef\xff\x00\x00\x00\x00\x96\x03\x8d\x03\x00\x00\xf4\x01\xf4\x01\xf4\x01\x00\x00\xf4\x01\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x03\x8d\x03\xd3\x03\x4d\x00\x00\x00\xa6\x01\xd0\x03\x89\x03\x00\x00\x89\x03\x00\x00\x00\x00\x4d\x00\x4d\x00\xbe\x03\x4d\x00\x77\x00\xd2\x03\x16\x03\xbc\x03\xd1\x03\xcc\x03\x00\x00\xc7\x03\x4d\x00\x84\x03\x4d\x00\x4d\x00\xbd\x03\xa7\x03\xb1\x02\xa3\x03\x00\x00\xf9\x00\xad\x03\x99\x03\x16\x03\xa8\x03\x7a\x02\xe8\x01\xae\x03\xa9\x03\xa0\x03\x54\x03\xa1\x03\x9e\x03\x93\x03\x83\x03\x87\x02\x5f\x01\x8a\x03\x86\x03\xeb\x02\x4d\x00\x81\x03\x00\x00\x2b\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x34\x03\x34\x03\x28\x00\x02\x00\x34\x03\x28\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x00\x00\x00\x00\x4b\x03\x00\x00\x49\x03\x00\x00\x18\x00\x2f\x02\x00\x00\x46\x03\x78\x03\x30\x00\x32\x03\x32\x03\x32\x03\x32\x03\x00\x00\x00\x00\x76\x03\x00\x00\xd6\x02\x33\x00\x25\x03\x72\x03\x00\x00\x28\x00\x28\x00\x00\x00\x6e\x03\x6a\x03\x00\x00\x57\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x03\x00\x00\x64\x03\x4a\x03\x00\x00\x00\x00\x53\x03\x00\x00\x00\x00\x87\x00\x00\x00\x4f\x03\x00\x00\xfc\x02\x00\x00\x40\x03\x44\x03\x00\x00\xc7\x02\xc7\x02\xc7\x02\x4d\x00\x00\x00\xf6\x02\x16\x03\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\xf6\x02\xc7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x02\x00\x00\xf6\x02\x42\x03\x00\x00\x00\x00\x00\x00\x14\x03\x00\x00\x16\x03\x4d\x00\x00\x00\xc7\x02\x00\x00\x00\x00\x4d\x00\x24\x03\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\x00\x00\x38\x03\x00\x00\x30\x03\x00\x00\x2e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x03\x00\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0b\x03\x20\x03\x1a\x03\x00\x00\x00\x00\x16\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x9b\x01\xe4\x02\xfa\xff\xfa\xff\x4d\x00\xfa\xff\x19\x03\xd9\x02\xd9\x02\x00\x00\x00\x00\x00\x00\x0e\x03\x4d\x00\x4d\x00\x10\x03\xfa\xff\x00\x00\x00\x00\x00\x00\x11\x03\x00\x00\xbc\x02\x0a\x00\xbc\x02\x07\x03\x0a\x00\xb9\x02\xfb\x02\xb3\x02\xf7\x02\x00\x00\xcb\x02\xf3\x02\xa9\x02\x00\x00\xaa\x02\xee\x02\x00\x00\x00\x00\x4d\x00\xe3\x02\x00\x00\x00\x00\x00\x00\xda\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x02\x00\x00\xd7\x02\xd2\x02\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x42\x01\x00\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x02\xcf\x02\x82\x02\x82\x02\x91\x03\x82\x02\x9b\x01\x4d\x00\x00\x00\xa0\x02\x0a\x00\x71\x03\xcd\x02\x0a\x00\x00\x00\x00\x00\xbe\x02\x00\x00\x00\x00\x6e\x02\x00\x00\xc4\x02\xb8\x02\x00\x00\x00\x00\xb5\x02\x00\x00\x00\x00\x4d\x00\x69\x02\xa7\x02\xa2\x02\x00\x00\x00\x00\x6f\x02\x97\x02\x00\x00\x9a\x02\x51\x03\x00\x00\x00\x00\x00\x00\x00\x00\x31\x03\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x78\x00\x22\x02\x8b\x01\x9e\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x03\x54\x04\x3c\x01\x96\x02\x00\x00\x17\x04\xca\x00\x93\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x07\x00\x00\x00\x00\xf2\x07\x6f\x03\x3c\x02\x00\x00\x00\x00\xd3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x19\x00\x00\x00\x81\x02\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x6d\x02\x6b\x02\x6a\x02\x5f\x02\x5d\x02\x5b\x02\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x22\x00\x13\x00\x07\x00\x4b\x02\xc8\x04\x00\x00\x4d\x01\x64\x07\x59\x02\xac\x04\x46\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x01\x46\x02\x50\x02\x00\x00\x0c\x03\x47\x02\x00\x00\xe7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x03\x44\x02\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x07\x00\x00\x00\x00\x00\x00\x00\x00\x44\x04\x00\x00\x00\x00\x2a\x07\xc3\x02\x0c\x07\xbc\x07\xad\x07\x2b\x03\xf0\x06\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x1c\x02\x1d\x03\x00\x00\x28\x04\x28\x04\x28\x04\x00\x00\x28\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x08\x02\x00\x00\xd2\x06\x00\x00\xcb\x07\x00\x00\x9b\x02\x00\x00\x07\x02\x00\x00\x00\x00\xfb\x03\xb6\x06\x00\x00\x98\x06\x5d\x00\x00\x00\xcb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x06\x00\x01\x5e\x06\x42\x06\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\xc0\x01\x8e\x04\x00\x00\x00\x00\x91\x01\xf4\x07\x77\x08\x75\x08\x69\x08\x64\x08\x5e\x08\x53\x08\x50\x08\x47\x08\xea\x01\x69\x01\x42\x08\x3d\x08\xdf\x01\x39\x08\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x00\x00\xd4\x01\x00\x00\x00\x00\xd5\x01\x8a\x01\xc2\x01\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\x00\x00\x95\x01\x00\x00\x00\x00\x2c\x08\xa0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x00\x00\x00\x00\x87\x01\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\xed\x03\x7d\x02\x24\x06\x00\x00\x7c\x01\x37\x00\x00\x00\x72\x04\xdd\x03\x00\x00\x00\x00\xd7\x01\x24\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x02\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x08\x06\x00\x00\x84\x00\x00\x00\x00\x00\xea\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x05\xb0\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x6c\x01\xad\x00\x47\x01\xa6\x00\x0d\x01\x94\x05\x26\x08\x00\x00\xb3\x00\x59\x01\x00\x00\x00\x00\x00\x00\x00\x00\x76\x05\x5a\x05\x00\x00\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\xab\x02\x90\x00\x00\x00\x2d\x02\xcd\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x05\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x04\x00\x00\xad\x00\x00\x00\x00\x00\xbf\x03\x20\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xf4\x00\xdb\x00\xfc\x00\xad\x00\x02\x05\x00\x00\xd3\x00\xcd\x01\xbc\x00\x00\x00\x99\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x04\xcb\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x53\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xf5\xff\xd8\xff\x17\xff\x00\x00\x00\x00\xfb\xff\x8e\xff\x8f\xff\x8d\xff\x93\xff\x82\xff\x7e\xff\x73\xff\x6e\xff\x60\xff\x61\xff\x00\x00\x6c\xff\x90\xff\x00\x00\x96\xff\x34\xff\x00\x00\x00\x00\x8c\xff\x2d\xff\x34\xff\x00\x00\x3f\xff\x3d\xff\x3c\xff\x3e\xff\x40\xff\x00\x00\x8a\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\xf9\xff\xf8\xff\xf7\xff\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\xd8\xff\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x15\xff\x14\xff\x00\x00\x16\xff\x00\x00\x00\x00\x00\x00\x18\xff\x5f\xff\x00\x00\x96\xff\x00\x00\x00\x00\x5f\xff\x00\x00\x52\xff\x50\xff\x51\xff\x55\xff\x75\xff\x3b\xff\x00\x00\x00\x00\x5a\xff\x2a\xff\x00\x00\x56\xff\x00\x00\x9f\xff\x00\x00\x95\xff\x00\x00\x96\xff\x00\x00\x23\xff\x00\x00\x72\xff\x36\xff\x33\xff\x00\x00\x34\xff\x35\xff\x2f\xff\x2c\xff\x00\x00\x00\x00\x00\x00\x5c\xff\x8b\xff\x93\xff\x00\x00\x00\x00\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xff\x00\x00\x42\xff\x81\xff\x00\x00\x96\xff\x67\xff\x70\xff\x71\xff\x6f\xff\x6b\xff\x6e\xff\x60\xff\x6d\xff\x68\xff\x87\xff\x92\xff\x00\x00\x00\x00\x93\xff\x00\x00\x83\xff\x5c\xff\x00\x00\x96\xff\x88\xff\x00\x00\x91\xff\x86\xff\x2d\xff\x00\x00\x00\x00\x00\x00\x34\xff\x00\x00\x38\xff\x00\x00\x22\xff\x00\x00\x62\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x74\xff\x58\xff\x55\xff\x47\xff\x44\xff\x2e\xff\x29\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9f\xff\x00\x00\x3a\xff\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x00\x00\x9f\xff\x00\x00\x26\xff\x00\x00\x00\x00\x5f\xff\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\xff\x12\xff\x11\xff\x0f\xff\x10\xff\xf0\xff\xee\xff\x00\x00\xef\xff\x00\x00\xf1\xff\xd6\xff\xd3\xff\xf2\xff\xdc\xff\xea\xff\xd5\xff\x00\x00\xd6\xff\x00\x00\x00\x00\x0e\xff\x9d\xff\x00\x00\xbf\xff\x9b\xff\x00\x00\x00\x00\x00\x00\xc3\xff\x00\x00\x00\x00\xc1\xff\xae\xff\x00\x00\xcb\xff\x00\x00\xca\xff\xc2\xff\xc8\xff\xc9\xff\xc7\xff\x00\x00\xcf\xff\x9b\xff\x00\x00\xc4\xff\xcd\xff\x00\x00\xce\xff\xcc\xff\x9b\xff\x1a\xff\x00\x00\xd0\xff\x00\x00\x78\xff\x00\x00\x00\x00\x7c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x4c\xff\x00\x00\x00\x00\x76\xff\x5f\xff\x1f\xff\x53\xff\x4f\xff\x3b\xff\x00\x00\x54\xff\x4d\xff\x59\xff\x48\xff\x4e\xff\x2a\xff\x4a\xff\x00\x00\x99\xff\x98\xff\x94\xff\x65\xff\x00\x00\x63\xff\x23\xff\x00\x00\x37\xff\x00\x00\x32\xff\x6a\xff\x00\x00\x00\x00\x2f\xff\x2b\xff\x7f\xff\x9f\xff\x89\xff\x5b\xff\x00\x00\x85\xff\x00\x00\x9e\xff\x00\x00\x41\xff\x64\xff\x80\xff\x31\xff\x84\xff\x69\xff\x00\x00\x24\xff\x21\xff\x00\x00\x00\x00\x57\xff\x28\xff\x43\xff\x39\xff\x00\x00\x1e\xff\x00\x00\x5d\xff\x49\xff\x53\xff\x27\xff\x45\xff\x46\xff\x25\xff\x7b\xff\x7a\xff\x1a\xff\xa8\xff\xb8\xff\xb2\xff\x00\x00\xa6\xff\x00\x00\xaa\xff\x00\x00\xa4\xff\xa2\xff\xc5\xff\xc6\xff\xbe\xff\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\xec\xff\xed\xff\xe4\xff\xd5\xff\xe5\xff\xd6\xff\xdf\xff\xe1\xff\x00\x00\xdf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\x00\x00\xde\xff\x00\x00\xe3\xff\x00\x00\xe9\xff\xd4\xff\xab\xff\x00\x00\xbd\xff\xbc\xff\x9c\xff\x1a\xff\xa1\xff\xaf\xff\xa3\xff\xe3\xff\xa9\xff\xb9\xff\xa5\xff\x00\x00\x9a\xff\xb4\xff\xb1\xff\xb5\xff\x1b\xff\x19\xff\x34\xff\xa7\xff\x00\x00\x4b\xff\x77\xff\x1f\xff\x00\x00\x97\xff\x66\xff\x79\xff\x20\xff\x1d\xff\xb7\xff\x00\x00\xb2\xff\x00\x00\x00\x00\xa2\xff\xad\xff\x00\x00\xbb\xff\xdc\xff\xdf\xff\x00\x00\x00\x00\xdf\xff\xdb\xff\xd2\xff\x00\x00\xd1\xff\xdd\xff\x00\x00\xeb\xff\xe7\xff\x00\x00\xba\xff\xa0\xff\x00\x00\xb3\xff\xb0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xe3\xff\xdc\xff\x00\x00\xd9\xff\x00\x00\x00\x00\x1c\xff\xb6\xff\xe8\xff\xe3\xff\x00\x00\xe6\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x09\x00\x0b\x00\x07\x00\x0d\x00\x09\x00\x01\x00\x03\x00\x03\x00\x09\x00\x1d\x00\x0f\x00\x10\x00\x11\x00\x01\x00\x07\x00\x03\x00\x03\x00\x01\x00\x17\x00\x03\x00\x1e\x00\x0a\x00\x1b\x00\x01\x00\x03\x00\x03\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x01\x00\x26\x00\x03\x00\x0a\x00\x29\x00\x0d\x00\x27\x00\x2c\x00\x07\x00\x09\x00\x2f\x00\x01\x00\x2d\x00\x03\x00\x09\x00\x34\x00\x0f\x00\x09\x00\x02\x00\x06\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x3e\x00\x3f\x00\x4f\x00\x0c\x00\x17\x00\x43\x00\x44\x00\x33\x00\x1b\x00\x0c\x00\x4d\x00\x49\x00\x4f\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x48\x00\x03\x00\x4f\x00\x3a\x00\x52\x00\x07\x00\x4f\x00\x09\x00\x48\x00\x49\x00\x4f\x00\x42\x00\x48\x00\x0f\x00\x10\x00\x11\x00\x47\x00\x03\x00\x48\x00\x49\x00\x03\x00\x17\x00\x12\x00\x2f\x00\x4f\x00\x4d\x00\x4d\x00\x48\x00\x4f\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x4f\x00\x26\x00\x05\x00\x48\x00\x29\x00\x4f\x00\x4f\x00\x2c\x00\x4f\x00\x4b\x00\x2f\x00\x05\x00\x06\x00\x31\x00\x05\x00\x34\x00\x13\x00\x14\x00\x00\x00\x01\x00\x02\x00\x03\x00\x19\x00\x02\x00\x0d\x00\x3e\x00\x3f\x00\x06\x00\x13\x00\x14\x00\x43\x00\x44\x00\x1b\x00\x03\x00\x37\x00\x38\x00\x49\x00\x37\x00\x38\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x12\x00\x52\x00\x11\x00\x07\x00\x03\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x17\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x17\x00\x18\x00\x4a\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0a\x00\x26\x00\x3e\x00\x3f\x00\x29\x00\x03\x00\x4f\x00\x2c\x00\x22\x00\x23\x00\x2f\x00\x00\x00\x19\x00\x03\x00\x12\x00\x34\x00\x03\x00\x03\x00\x1f\x00\x26\x00\x2f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x3e\x00\x3f\x00\x36\x00\x06\x00\x03\x00\x43\x00\x44\x00\x0d\x00\x34\x00\x0c\x00\x21\x00\x49\x00\x40\x00\x41\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x12\x00\x21\x00\x21\x00\x07\x00\x44\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x17\x00\x37\x00\x38\x00\x03\x00\x2f\x00\x30\x00\x31\x00\x0e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x15\x00\x26\x00\x03\x00\x03\x00\x29\x00\x3e\x00\x3f\x00\x2c\x00\x1a\x00\x09\x00\x2f\x00\x0b\x00\x03\x00\x0a\x00\x20\x00\x34\x00\x10\x00\x11\x00\x09\x00\x21\x00\x2f\x00\x16\x00\x24\x00\x25\x00\x45\x00\x3e\x00\x3f\x00\x36\x00\x2f\x00\x1e\x00\x43\x00\x44\x00\x03\x00\x22\x00\x0a\x00\x36\x00\x49\x00\x40\x00\x41\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x10\x00\x11\x00\x01\x00\x07\x00\x03\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x03\x00\x09\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x03\x00\x45\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x03\x00\x26\x00\x17\x00\x18\x00\x29\x00\x03\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x0e\x00\x21\x00\x03\x00\x2f\x00\x24\x00\x25\x00\x1a\x00\x15\x00\x3e\x00\x3f\x00\x36\x00\x19\x00\x20\x00\x43\x00\x44\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x49\x00\x15\x00\x19\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x1f\x00\x1d\x00\x03\x00\x3e\x00\x3f\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x03\x00\x45\x00\x2f\x00\x07\x00\x03\x00\x09\x00\x10\x00\x11\x00\x03\x00\x36\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x03\x00\x09\x00\x0c\x00\x15\x00\x0e\x00\x18\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x1d\x00\x09\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x10\x00\x11\x00\x04\x00\x29\x00\x06\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x46\x00\x47\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\x0c\x00\x03\x00\x0e\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0d\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x04\x00\x03\x00\x06\x00\x2f\x00\x30\x00\x31\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x21\x00\x26\x00\x2f\x00\x07\x00\x03\x00\x09\x00\x3e\x00\x3f\x00\x03\x00\x36\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x34\x00\x09\x00\x32\x00\x03\x00\x03\x00\x35\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x2f\x00\x09\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x29\x00\x21\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x07\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x32\x00\x03\x00\x0f\x00\x35\x00\x29\x00\x00\x00\x01\x00\x02\x00\x03\x00\x09\x00\x0c\x00\x0b\x00\x0e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x01\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0d\x00\x01\x00\x0f\x00\x2f\x00\x30\x00\x31\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x03\x00\x12\x00\x03\x00\x07\x00\x03\x00\x09\x00\x03\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x2f\x00\x09\x00\x03\x00\x03\x00\x3b\x00\x03\x00\x3d\x00\x0f\x00\x10\x00\x11\x00\x2f\x00\x30\x00\x31\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x08\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0e\x00\x08\x00\x03\x00\x04\x00\x29\x00\x06\x00\x07\x00\x15\x00\x09\x00\x04\x00\x0a\x00\x06\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x11\x00\x03\x00\x0d\x00\x14\x00\x15\x00\x03\x00\x03\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x3a\x00\x08\x00\x04\x00\x2f\x00\x30\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x4c\x00\x01\x00\x0c\x00\x07\x00\x0e\x00\x09\x00\x03\x00\x21\x00\x4f\x00\x0d\x00\x24\x00\x25\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x0a\x00\x05\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x07\x00\x02\x00\x09\x00\x4f\x00\x0b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x10\x00\x11\x00\x03\x00\x3a\x00\x0c\x00\x06\x00\x07\x00\x03\x00\x09\x00\x0e\x00\x1a\x00\x1b\x00\x02\x00\x0d\x00\x02\x00\x10\x00\x11\x00\x0e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x1a\x00\x1b\x00\x07\x00\x05\x00\x09\x00\x4b\x00\x0b\x00\x34\x00\x4f\x00\x06\x00\x2f\x00\x10\x00\x11\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x0a\x00\x4f\x00\x03\x00\x09\x00\x1a\x00\x1b\x00\x07\x00\x4f\x00\x09\x00\x03\x00\x4f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x10\x00\x11\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x06\x00\x0a\x00\x03\x00\x1a\x00\x1b\x00\x03\x00\x07\x00\x04\x00\x09\x00\x03\x00\x01\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x10\x00\x11\x00\x4f\x00\x1e\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1a\x00\x1b\x00\x04\x00\x4f\x00\x04\x00\x04\x00\x12\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x2f\x00\x30\x00\x31\x00\x21\x00\x03\x00\x08\x00\x24\x00\x25\x00\x2f\x00\x02\x00\x4f\x00\x46\x00\x3b\x00\x04\x00\x3d\x00\x0a\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x01\x00\x26\x00\x27\x00\x28\x00\x01\x00\x04\x00\x0c\x00\x01\x00\x27\x00\x02\x00\x29\x00\x2a\x00\x2b\x00\x21\x00\x2d\x00\x34\x00\x24\x00\x25\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x35\x00\x36\x00\x37\x00\x38\x00\x06\x00\x01\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x03\x00\x01\x00\x4f\x00\x04\x00\x45\x00\x01\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x05\x00\x2d\x00\x03\x00\x3a\x00\x4f\x00\x39\x00\x4f\x00\x39\x00\x04\x00\x35\x00\x36\x00\x37\x00\x38\x00\x04\x00\x01\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x21\x00\x40\x00\x0f\x00\x24\x00\x25\x00\x04\x00\x45\x00\x04\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x21\x00\x2d\x00\x01\x00\x24\x00\x25\x00\x01\x00\x4f\x00\x04\x00\x03\x00\x35\x00\x36\x00\x37\x00\x38\x00\x01\x00\x12\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x0a\x00\x06\x00\x0d\x00\x13\x00\x45\x00\x14\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x1b\x00\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x22\x00\x23\x00\x35\x00\x36\x00\x37\x00\x38\x00\x0d\x00\x04\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x04\x00\x40\x00\x01\x00\x4f\x00\x18\x00\x03\x00\x45\x00\x19\x00\x4f\x00\x48\x00\x0a\x00\x08\x00\x4f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4c\x00\x0d\x00\x03\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0c\x00\x08\x00\x34\x00\x12\x00\x0a\x00\x06\x00\x18\x00\x39\x00\x06\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4f\x00\x42\x00\x43\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2f\x00\x01\x00\x06\x00\x39\x00\x4d\x00\x4f\x00\x0d\x00\x34\x00\x4f\x00\x4f\x00\x01\x00\x4f\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x2f\x00\x30\x00\x02\x00\x42\x00\x43\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x52\x00\x34\x00\x03\x00\x03\x00\x03\x00\x03\x00\x39\x00\x3a\x00\x4f\x00\x3c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x18\x00\x15\x00\x34\x00\x52\x00\x16\x00\x26\x00\x27\x00\x39\x00\x3a\x00\x0d\x00\x3c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4c\x00\x30\x00\xff\xff\x34\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x34\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x13\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\xff\xff\x1b\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x22\x00\x23\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x28\x00\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x26\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x34\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x2e\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x34\x00\x26\x00\x27\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\x26\x00\x27\x00\xff\xff\x34\x00\xff\xff\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x03\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x03\x00\xff\xff\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x34\x00\x40\x00\xff\xff\xff\xff\xff\xff\x14\x00\x45\x00\x03\x00\xff\xff\x48\x00\x13\x00\x03\x00\xff\xff\x1c\x00\xff\xff\xff\xff\x03\x00\xff\xff\x1b\x00\x22\x00\x23\x00\x03\x00\xff\xff\x13\x00\xff\xff\x22\x00\x23\x00\x13\x00\xff\xff\xff\xff\x03\x00\x1b\x00\x13\x00\x03\x00\xff\xff\x1b\x00\xff\xff\x13\x00\x22\x00\x23\x00\x1b\x00\xff\xff\x22\x00\x23\x00\x03\x00\x1b\x00\x13\x00\x22\x00\x23\x00\x13\x00\x03\x00\xff\xff\x22\x00\x23\x00\x1b\x00\x03\x00\xff\xff\x1b\x00\xff\xff\xff\xff\x13\x00\x22\x00\x23\x00\xff\xff\x22\x00\x23\x00\x13\x00\x03\x00\x1b\x00\x03\x00\xff\xff\xff\xff\x14\x00\xff\xff\x1b\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x1c\x00\x22\x00\x23\x00\x13\x00\xff\xff\x13\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1b\x00\x25\x00\xff\xff\xff\xff\x28\x00\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x15\x00\x40\x00\xf4\x00\x45\x00\x16\x00\x46\x00\x17\x00\x40\x00\x61\x00\x41\x00\xf4\x00\x84\x00\x18\x00\x19\x00\x1a\x00\x40\x00\x83\x01\x41\x00\x81\x00\x40\x00\x1b\x00\x41\x00\x47\x00\xd2\x01\x6a\x00\x40\x00\xe0\xff\x41\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x40\x00\x22\x00\x41\x00\x71\x00\x23\x00\x81\x00\xf7\x00\x24\x00\x37\x00\x10\x01\x75\x00\x40\x00\xf8\x00\x41\x00\xf4\x00\x26\x00\x33\x00\x10\x01\x6e\x01\x77\x01\x4f\x00\x50\x00\x51\x00\x52\x00\xab\x00\x27\x00\x28\x00\x2e\x00\x6f\x01\x69\x00\x29\x00\x2a\x00\x82\x00\x6a\x00\xac\x00\x2c\x00\x2b\x00\x2e\x00\x2e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xd8\x00\x15\x00\x2e\x00\xe0\xff\xff\xff\x16\x00\x2e\x00\x17\x00\x42\x00\xed\x00\x2e\x00\xea\x00\xd9\x00\x18\x00\x19\x00\x1a\x00\xeb\x00\x65\x00\x42\x00\x43\x00\x65\x00\x1b\x00\xc7\x00\x56\x01\x2e\x00\x2c\x00\x2c\x00\xda\x00\x2e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x2e\x00\x22\x00\x7b\x00\xdc\x00\x23\x00\x2e\x00\x2e\x00\x24\x00\x2e\x00\x78\x01\x25\x00\x35\x00\x36\x00\x35\x00\x7b\x00\x26\x00\x7c\x00\x7d\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x7e\x00\x62\x01\xcc\x01\x27\x00\x28\x00\x63\x01\x7c\x00\x7d\x00\x29\x00\x2a\x00\x6a\x00\xe4\x00\x66\x00\x34\x01\x2b\x00\x66\x00\x9e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xc7\x00\xf6\xff\x84\x01\x16\x00\x96\x01\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\xee\x00\x18\x00\x19\x00\x1a\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1b\x00\xaf\x00\xb0\x00\xc1\x00\xf9\x00\x97\x01\xc2\x01\x7f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xcd\x01\x22\x00\xc2\x00\x49\x01\x23\x00\x5c\x00\x2e\x00\x24\x00\x04\x01\x95\x01\x75\x00\xc5\x01\xfa\x00\x65\x00\xc7\x00\x26\x00\x5c\x00\x5c\x00\x8f\x01\x99\x01\xa2\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x27\x00\x28\x00\xa3\x00\x36\xff\xca\x01\x29\x00\x2a\x00\xbd\x01\x12\x00\x36\xff\xb7\x01\x2b\x00\xa4\x00\x4b\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xc7\x00\x7e\x01\x41\x01\x16\x00\x9a\x01\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\xc1\x01\x18\x00\x19\x00\x1a\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x8c\x01\x1b\x00\x66\x00\x67\x00\x5c\x00\xaf\x00\xb0\x00\xc1\x00\x16\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x17\x01\x22\x00\xee\x00\xe4\x00\x23\x00\xc2\x00\x5b\x01\x24\x00\x8d\x01\xe5\x00\x25\x00\xe6\x00\xc5\x00\xab\x01\xbf\x01\x26\x00\xe7\x00\xe8\x00\xc6\x00\x5d\x00\xa2\x00\x08\x01\x5e\x00\x2c\x01\xad\x01\x27\x00\x28\x00\xa3\x00\xa2\x00\x93\x01\x29\x00\x2a\x00\xe4\x00\x94\x01\xb2\x01\x9e\x01\x2b\x00\xa4\x00\xa5\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\x86\x01\x74\x01\x6e\x00\x4c\x00\x6f\x00\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x98\x00\x18\x00\x19\x00\x1a\x00\x9c\x01\x96\x01\x17\x00\xa8\x01\x4f\x00\x50\x00\x51\x00\xc0\x00\x4d\x00\x19\x00\x1a\x00\xb3\x01\x9d\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x8c\x01\x22\x00\x97\x01\x98\x01\x23\x00\x4e\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x23\x00\xf9\x00\x16\x01\x5d\x00\x0c\x01\xa2\x00\x5e\x00\x76\x00\x8d\x01\x17\x01\x27\x00\x28\x00\x6f\x01\x18\x01\x8e\x01\x29\x00\x2a\x00\xaf\x00\xb0\x00\xc1\x00\x57\x01\x2b\x00\x0d\x01\xfa\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xfb\x00\x9c\x01\x5e\x01\xc2\x00\xc3\x00\xe4\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\x0c\x01\x60\x01\xa2\x00\x4c\x00\x6c\x01\x17\x00\x73\x01\x74\x01\x7f\x01\x18\x01\x98\x00\x18\x00\x19\x00\x1a\x00\x9c\x01\x71\x01\x17\x00\xb9\x01\x0d\x01\x81\x01\x30\xff\x98\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x0e\x01\x17\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4d\x00\x19\x00\x1a\x00\x90\x00\x23\x00\x91\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x72\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x23\x00\x7f\x01\x2f\x00\x30\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x75\x01\xbc\x01\x5c\x00\x81\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x79\x01\xf4\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x23\x01\xfc\x00\x91\x00\xaf\x00\xb0\x00\xc1\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xb8\x00\x49\x00\xa2\x00\x4c\x00\x1e\x01\x17\x00\xc2\x00\x12\x01\xb7\x00\x32\x01\x98\x00\x18\x00\x19\x00\x1a\x00\x4c\x00\x12\x00\x17\x00\xb9\x00\x3a\x01\x40\x01\x51\x01\x15\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x25\x01\x17\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x18\x00\x19\x00\x1a\x00\x43\x01\x23\x00\xb8\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x32\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xb9\x00\x7f\x01\x33\x00\xba\x00\x23\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x7c\x01\x80\x01\x7d\x01\x81\x01\x4f\x00\x50\x00\x51\x00\x52\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xa6\x00\x4f\x00\x50\x00\x51\x00\xae\x00\xad\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x9a\x00\xb5\x00\x9b\x00\xaf\x00\xb0\x00\x50\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x4b\x00\xbf\x00\xc7\x00\xdd\x00\x4c\x00\xde\x00\x17\x00\xdf\x00\xaf\x00\xb0\x00\xb1\x00\x15\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x53\x00\x17\x00\xe0\x00\xe1\x00\xb2\x00\xe2\x00\x4f\x01\x18\x00\x19\x00\x1a\x00\xaf\x00\xb0\x00\xb6\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x24\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x16\x01\x38\x00\x55\x00\x90\x00\x23\x00\x91\x00\x56\x00\x17\x01\x57\x00\x90\x00\x47\x00\x91\x00\x1a\x01\x55\xff\x64\x00\x58\x00\x59\x00\x6d\x00\x92\x00\x55\xff\x55\xff\xd2\x01\x3b\x01\xcc\x01\x55\xff\x5a\x00\x5b\x00\x1b\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x7b\x01\xcf\x01\xd0\x01\xaf\x00\x59\x01\x7f\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x55\x00\x06\x00\xc8\x01\x85\x01\x56\x00\x81\x01\x57\x00\xc9\x01\x5d\x00\x2e\x00\x1a\x01\x5e\x00\x76\x00\x58\x00\x59\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xb9\x01\xca\x01\x55\x00\x5a\x00\x5b\x00\x1b\x01\x56\x00\xbb\x01\x57\x00\x2e\x00\xb5\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x58\x00\x59\x00\x55\x00\x7b\x01\xc4\x01\x63\x01\x56\x00\xc5\x01\x57\x00\xaa\x01\x5a\x00\x5b\x00\x62\x01\xab\x01\xaf\x01\x58\x00\x59\x00\xad\x01\x0b\x00\x0c\x00\x8a\x00\x8b\x00\x8c\x00\x55\x00\x11\x00\x5a\x00\x5b\x00\x56\x00\xb1\x01\x57\x00\xb2\x01\xb5\x00\x12\x00\x2e\x00\xb5\x01\xb6\x01\x58\x00\x59\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\xb7\x01\x2e\x00\x55\x00\x7e\x01\x5a\x00\x5b\x00\x56\x00\x2e\x00\x57\x00\x84\x01\x2e\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x58\x00\x59\x00\x89\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x77\x01\x8c\x01\x55\x00\x5a\x00\x5b\x00\x91\x01\x56\x00\xa0\x01\x57\x00\x5c\x00\xa1\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x58\x00\x59\x00\x2e\x00\xa2\x01\xa5\x01\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x5a\x00\x5b\x00\x45\x01\x2e\x00\x46\x01\xd4\x01\x48\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\xaf\x00\xb0\x00\xb1\x00\x5d\x00\x5c\x00\x47\x01\x5e\x00\x42\x01\x4d\x01\x4e\x01\x2e\x00\x5c\x00\xb2\x00\x5d\x01\xb3\x00\x5e\x01\x2e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x60\x01\x0b\x00\x0c\x00\x86\x00\x64\x01\xd1\x01\x65\x01\x66\x01\xc9\x00\x67\x01\xca\x00\xcb\x00\xcc\x00\x5d\x00\xcd\x00\x12\x00\x5e\x00\xa7\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x63\x01\x68\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x69\x01\xd6\x00\x5c\x00\x6c\x01\x2e\x00\xbc\x01\xd7\x00\x71\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x79\x01\xcd\x00\x75\x00\x7b\x01\x2e\x00\xec\x00\x2e\x00\xed\x00\x11\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\x14\x01\x15\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x5d\x00\xd6\x00\x9b\x00\x5e\x00\x5f\x00\xc1\x01\xd7\x00\x1c\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x5d\x00\xcd\x00\x1d\x01\x5e\x00\x76\x00\x1e\x01\x2e\x00\x20\x01\xee\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x21\x01\x27\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x22\x01\xd6\x00\x25\x01\x28\x01\x2a\x01\xef\x00\xd7\x00\x29\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x87\x01\xcd\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xf1\x00\xf2\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x81\x00\x2f\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x30\x01\xd6\x00\x31\x01\x2e\x00\x32\x01\x34\x01\xd7\x00\x37\x01\x2e\x00\xd8\x00\x3d\x01\x40\x01\x2e\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x06\x00\x81\x00\x85\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x01\x11\x00\x8f\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x94\x00\x95\x00\x12\x00\x9c\x00\x99\x00\x9d\x00\xa0\x00\x13\x00\xa1\x00\x9e\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x2e\x00\x53\x01\xa6\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x01\x11\x00\xa9\x00\xaa\x00\x91\x00\xa2\x00\x2c\x00\x2e\x00\xbc\x00\x12\x00\x2e\x00\x2e\x00\xdc\x00\x2e\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xaf\x00\x5a\x01\xe4\x00\x53\x01\x54\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x38\x01\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x40\x00\xff\xff\x12\x00\x49\x00\x4e\x00\x4f\x00\x63\x00\x13\x00\x6b\x00\x2e\x00\x39\x01\x06\x00\x07\x00\x08\x00\x71\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x6a\x00\x11\x00\x06\x00\x07\x00\x08\x00\x92\x00\x0a\x00\x78\x00\x79\x00\x12\x00\xff\xff\x7a\x00\x0b\x00\x7f\x00\x13\x00\x6b\x00\x81\x00\x6c\x00\x06\x00\x07\x00\x08\x00\x71\x00\x0a\x00\x06\x00\x32\x00\x00\x00\x12\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x61\x00\x12\x00\x00\x00\x00\x00\x66\x00\xa8\x01\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x12\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x66\x00\x73\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xc6\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbe\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa5\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xaf\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x89\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x8a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x92\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa2\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa3\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x48\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x4a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x58\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2d\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x35\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x37\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x3e\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x85\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x89\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x8d\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbc\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xee\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x63\x00\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\xef\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x69\x01\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\xf1\x00\xf2\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x0c\x00\x87\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x0c\x00\x88\x00\x00\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x95\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xee\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x12\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x96\x00\x00\x00\x02\x01\x00\x00\x08\x01\x00\x00\x12\x00\x0b\x00\xac\x00\x00\x00\x09\x01\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x0b\x01\x05\x01\x0b\x00\x61\x00\x00\x00\x12\x00\x00\x00\xc9\x00\x00\x00\xca\x00\xcb\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x7f\x00\xee\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xee\x00\x00\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x12\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x02\x01\xd7\x00\xee\x00\x00\x00\xd8\x00\xef\x00\xee\x00\x00\x00\x91\x01\x00\x00\x00\x00\xee\x00\x00\x00\x6a\x01\x04\x01\x05\x01\xee\x00\x00\x00\xef\x00\x00\x00\xf1\x00\xf2\x00\xef\x00\x00\x00\x00\x00\xee\x00\xf0\x00\xef\x00\xee\x00\x00\x00\xf5\x00\x00\x00\xef\x00\xf1\x00\xf2\x00\xf8\x00\x00\x00\xf1\x00\xf2\x00\xee\x00\xfd\x00\xef\x00\xf1\x00\xf2\x00\xef\x00\xee\x00\x00\x00\xf1\x00\xf2\x00\xfe\x00\xee\x00\x00\x00\xff\x00\x00\x00\x00\x00\xef\x00\xf1\x00\xf2\x00\x00\x00\xf1\x00\xf2\x00\xef\x00\xee\x00\x00\x01\xee\x00\x00\x00\x00\x00\x02\x01\x00\x00\x01\x01\xf1\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x03\x01\xf1\x00\xf2\x00\xef\x00\x00\x00\xef\x00\x04\x01\x05\x01\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x07\x01\x3a\x00\x00\x00\x00\x00\x3b\x00\xf1\x00\xf2\x00\xf1\x00\xf2\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (4, 241) [ - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241) - ] - -happy_n_terms = 83 :: Int -happy_n_nonterms = 74 :: Int - -happyReduce_4 = happySpecReduce_1 0# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn7 - ((read happy_var_1) :: Integer - )} - -happyReduce_5 = happySpecReduce_1 1# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn8 - (happy_var_1 - )} - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> - happyIn9 - ((read happy_var_1) :: Double - )} - -happyReduce_7 = happySpecReduce_1 3# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn10 - (PIdent (mkPosToken happy_var_1) - )} - -happyReduce_8 = happySpecReduce_1 4# happyReduction_8 -happyReduction_8 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (T_LString happy_var_1)) -> - happyIn11 - (LString (happy_var_1) - )} - -happyReduce_9 = happySpecReduce_1 5# happyReduction_9 -happyReduction_9 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - happyIn12 - (Gr (reverse happy_var_1) - )} - -happyReduce_10 = happySpecReduce_0 6# happyReduction_10 -happyReduction_10 = happyIn13 - ([] - ) - -happyReduce_11 = happySpecReduce_2 6# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn13 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happySpecReduce_2 7# happyReduction_12 -happyReduction_12 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - happyIn14 - (happy_var_1 - )} - -happyReduce_13 = happyReduce 4# 7# happyReduction_13 -happyReduction_13 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut16 happy_x_4 of { happy_var_4 -> - happyIn14 - (MModule happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_14 = happySpecReduce_2 8# happyReduction_14 -happyReduction_14 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MAbstract happy_var_2 - )} - -happyReduce_15 = happySpecReduce_2 8# happyReduction_15 -happyReduction_15 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MResource happy_var_2 - )} - -happyReduce_16 = happySpecReduce_2 8# happyReduction_16 -happyReduction_16 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MGrammar happy_var_2 - )} - -happyReduce_17 = happySpecReduce_2 8# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn15 - (MInterface happy_var_2 - )} - -happyReduce_18 = happyReduce 4# 8# happyReduction_18 -happyReduction_18 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn15 - (MConcrete happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_19 = happyReduce 4# 8# happyReduction_19 -happyReduction_19 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn15 - (MInstance happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_20 = happyReduce 5# 9# happyReduction_20 -happyReduction_20 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn16 - (MBody happy_var_1 happy_var_2 (reverse happy_var_4) - ) `HappyStk` happyRest}}} - -happyReduce_21 = happySpecReduce_1 9# happyReduction_21 -happyReduction_21 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn16 - (MNoBody happy_var_1 - )} - -happyReduce_22 = happySpecReduce_3 9# happyReduction_22 -happyReduction_22 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn16 - (MWith happy_var_1 happy_var_3 - )}} - -happyReduce_23 = happyReduce 8# 9# happyReduction_23 -happyReduction_23 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - case happyOut17 happy_x_7 of { happy_var_7 -> - happyIn16 - (MWithBody happy_var_1 happy_var_3 happy_var_5 (reverse happy_var_7) - ) `HappyStk` happyRest}}}} - -happyReduce_24 = happyReduce 5# 9# happyReduction_24 -happyReduction_24 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - case happyOut19 happy_x_5 of { happy_var_5 -> - happyIn16 - (MWithE happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_25 = happyReduce 10# 9# happyReduction_25 -happyReduction_25 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - case happyOut19 happy_x_5 of { happy_var_5 -> - case happyOut20 happy_x_7 of { happy_var_7 -> - case happyOut17 happy_x_9 of { happy_var_9 -> - happyIn16 - (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 (reverse happy_var_9) - ) `HappyStk` happyRest}}}}} - -happyReduce_26 = happySpecReduce_2 9# happyReduction_26 -happyReduction_26 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn16 - (MReuse happy_var_2 - )} - -happyReduce_27 = happySpecReduce_2 9# happyReduction_27 -happyReduction_27 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn16 - (MUnion happy_var_2 - )} - -happyReduce_28 = happySpecReduce_0 10# happyReduction_28 -happyReduction_28 = happyIn17 - ([] - ) - -happyReduce_29 = happySpecReduce_2 10# happyReduction_29 -happyReduction_29 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn17 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_30 = happySpecReduce_2 11# happyReduction_30 -happyReduction_30 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn18 - (Ext happy_var_1 - )} - -happyReduce_31 = happySpecReduce_0 11# happyReduction_31 -happyReduction_31 = happyIn18 - (NoExt - ) - -happyReduce_32 = happySpecReduce_0 12# happyReduction_32 -happyReduction_32 = happyIn19 - ([] - ) - -happyReduce_33 = happySpecReduce_1 12# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn19 - ((:[]) happy_var_1 - )} - -happyReduce_34 = happySpecReduce_3 12# happyReduction_34 -happyReduction_34 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn19 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_35 = happySpecReduce_0 13# happyReduction_35 -happyReduction_35 = happyIn20 - (NoOpens - ) - -happyReduce_36 = happySpecReduce_3 13# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn20 - (OpenIn happy_var_2 - )} - -happyReduce_37 = happySpecReduce_1 14# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn21 - (OName happy_var_1 - )} - -happyReduce_38 = happyReduce 5# 14# happyReduction_38 -happyReduction_38 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn21 - (OQual happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_39 = happySpecReduce_0 15# happyReduction_39 -happyReduction_39 = happyIn22 - (CMCompl - ) - -happyReduce_40 = happySpecReduce_1 15# happyReduction_40 -happyReduction_40 happy_x_1 - = happyIn22 - (CMIncompl - ) - -happyReduce_41 = happySpecReduce_0 16# happyReduction_41 -happyReduction_41 = happyIn23 - ([] - ) - -happyReduce_42 = happySpecReduce_1 16# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - happyIn23 - ((:[]) happy_var_1 - )} - -happyReduce_43 = happySpecReduce_3 16# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn23 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_44 = happySpecReduce_1 17# happyReduction_44 -happyReduction_44 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn24 - (IAll happy_var_1 - )} - -happyReduce_45 = happyReduce 4# 17# happyReduction_45 -happyReduction_45 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_3 of { happy_var_3 -> - happyIn24 - (ISome happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_46 = happyReduce 5# 17# happyReduction_46 -happyReduction_46 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_4 of { happy_var_4 -> - happyIn24 - (IMinus happy_var_1 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_47 = happySpecReduce_2 18# happyReduction_47 -happyReduction_47 happy_x_2 - happy_x_1 - = case happyOut36 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefCat happy_var_2 - )} - -happyReduce_48 = happySpecReduce_2 18# happyReduction_48 -happyReduction_48 happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefFun happy_var_2 - )} - -happyReduce_49 = happySpecReduce_2 18# happyReduction_49 -happyReduction_49 happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefFunData happy_var_2 - )} - -happyReduce_50 = happySpecReduce_2 18# happyReduction_50 -happyReduction_50 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefDef happy_var_2 - )} - -happyReduce_51 = happySpecReduce_2 18# happyReduction_51 -happyReduction_51 happy_x_2 - happy_x_1 - = case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefData happy_var_2 - )} - -happyReduce_52 = happySpecReduce_2 18# happyReduction_52 -happyReduction_52 happy_x_2 - happy_x_1 - = case happyOut38 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefPar happy_var_2 - )} - -happyReduce_53 = happySpecReduce_2 18# happyReduction_53 -happyReduction_53 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefOper happy_var_2 - )} - -happyReduce_54 = happySpecReduce_2 18# happyReduction_54 -happyReduction_54 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLincat happy_var_2 - )} - -happyReduce_55 = happySpecReduce_2 18# happyReduction_55 -happyReduction_55 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLindef happy_var_2 - )} - -happyReduce_56 = happySpecReduce_2 18# happyReduction_56 -happyReduction_56 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLin happy_var_2 - )} - -happyReduce_57 = happySpecReduce_3 18# happyReduction_57 -happyReduction_57 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn25 - (DefPrintCat happy_var_3 - )} - -happyReduce_58 = happySpecReduce_3 18# happyReduction_58 -happyReduction_58 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn25 - (DefPrintFun happy_var_3 - )} - -happyReduce_59 = happySpecReduce_2 18# happyReduction_59 -happyReduction_59 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefFlag happy_var_2 - )} - -happyReduce_60 = happySpecReduce_2 18# happyReduction_60 -happyReduction_60 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefPrintOld happy_var_2 - )} - -happyReduce_61 = happySpecReduce_2 18# happyReduction_61 -happyReduction_61 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefLintype happy_var_2 - )} - -happyReduce_62 = happySpecReduce_2 18# happyReduction_62 -happyReduction_62 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefPattern happy_var_2 - )} - -happyReduce_63 = happyReduce 7# 18# happyReduction_63 -happyReduction_63 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_5 of { happy_var_5 -> - happyIn25 - (DefPackage happy_var_2 (reverse happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_64 = happySpecReduce_2 18# happyReduction_64 -happyReduction_64 happy_x_2 - happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefVars happy_var_2 - )} - -happyReduce_65 = happySpecReduce_3 18# happyReduction_65 -happyReduction_65 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn25 - (DefTokenizer happy_var_2 - )} - -happyReduce_66 = happySpecReduce_3 19# happyReduction_66 -happyReduction_66 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn26 - (DDecl happy_var_1 happy_var_3 - )}} - -happyReduce_67 = happySpecReduce_3 19# happyReduction_67 -happyReduction_67 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn26 - (DDef happy_var_1 happy_var_3 - )}} - -happyReduce_68 = happyReduce 4# 19# happyReduction_68 -happyReduction_68 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn26 - (DPatt happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_69 = happyReduce 5# 19# happyReduction_69 -happyReduction_69 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn26 - (DFull happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_70 = happySpecReduce_3 20# happyReduction_70 -happyReduction_70 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn27 - (FDecl happy_var_1 happy_var_3 - )}} - -happyReduce_71 = happySpecReduce_2 21# happyReduction_71 -happyReduction_71 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - happyIn28 - (SimpleCatDef happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_72 = happyReduce 4# 21# happyReduction_72 -happyReduction_72 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut76 happy_x_3 of { happy_var_3 -> - happyIn28 - (ListCatDef happy_var_2 (reverse happy_var_3) - ) `HappyStk` happyRest}} - -happyReduce_73 = happyReduce 7# 21# happyReduction_73 -happyReduction_73 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut76 happy_x_3 of { happy_var_3 -> - case happyOut7 happy_x_6 of { happy_var_6 -> - happyIn28 - (ListSizeCatDef happy_var_2 (reverse happy_var_3) happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_74 = happySpecReduce_3 22# happyReduction_74 -happyReduction_74 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn29 - (DataDef happy_var_1 happy_var_3 - )}} - -happyReduce_75 = happySpecReduce_1 23# happyReduction_75 -happyReduction_75 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn30 - (DataId happy_var_1 - )} - -happyReduce_76 = happySpecReduce_3 23# happyReduction_76 -happyReduction_76 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn30 - (DataQId happy_var_1 happy_var_3 - )}} - -happyReduce_77 = happySpecReduce_0 24# happyReduction_77 -happyReduction_77 = happyIn31 - ([] - ) - -happyReduce_78 = happySpecReduce_1 24# happyReduction_78 -happyReduction_78 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn31 - ((:[]) happy_var_1 - )} - -happyReduce_79 = happySpecReduce_3 24# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn31 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_80 = happySpecReduce_3 25# happyReduction_80 -happyReduction_80 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn32 - (ParDefDir happy_var_1 happy_var_3 - )}} - -happyReduce_81 = happySpecReduce_1 25# happyReduction_81 -happyReduction_81 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn32 - (ParDefAbs happy_var_1 - )} - -happyReduce_82 = happySpecReduce_2 26# happyReduction_82 -happyReduction_82 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - happyIn33 - (ParConstr happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_83 = happySpecReduce_2 27# happyReduction_83 -happyReduction_83 happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn34 - ((:[]) happy_var_1 - )} - -happyReduce_84 = happySpecReduce_3 27# happyReduction_84 -happyReduction_84 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn34 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_85 = happySpecReduce_2 28# happyReduction_85 -happyReduction_85 happy_x_2 - happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - happyIn35 - ((:[]) happy_var_1 - )} - -happyReduce_86 = happySpecReduce_3 28# happyReduction_86 -happyReduction_86 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - case happyOut35 happy_x_3 of { happy_var_3 -> - happyIn35 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_87 = happySpecReduce_2 29# happyReduction_87 -happyReduction_87 happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn36 - ((:[]) happy_var_1 - )} - -happyReduce_88 = happySpecReduce_3 29# happyReduction_88 -happyReduction_88 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn36 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_89 = happySpecReduce_2 30# happyReduction_89 -happyReduction_89 happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn37 - ((:[]) happy_var_1 - )} - -happyReduce_90 = happySpecReduce_3 30# happyReduction_90 -happyReduction_90 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn37 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_91 = happySpecReduce_2 31# happyReduction_91 -happyReduction_91 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn38 - ((:[]) happy_var_1 - )} - -happyReduce_92 = happySpecReduce_3 31# happyReduction_92 -happyReduction_92 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn38 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_93 = happySpecReduce_0 32# happyReduction_93 -happyReduction_93 = happyIn39 - ([] - ) - -happyReduce_94 = happySpecReduce_1 32# happyReduction_94 -happyReduction_94 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn39 - ((:[]) happy_var_1 - )} - -happyReduce_95 = happySpecReduce_3 32# happyReduction_95 -happyReduction_95 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - case happyOut39 happy_x_3 of { happy_var_3 -> - happyIn39 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_96 = happySpecReduce_1 33# happyReduction_96 -happyReduction_96 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn40 - ((:[]) happy_var_1 - )} - -happyReduce_97 = happySpecReduce_3 33# happyReduction_97 -happyReduction_97 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_3 of { happy_var_3 -> - happyIn40 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_98 = happySpecReduce_1 34# happyReduction_98 -happyReduction_98 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn41 - (PIdentName happy_var_1 - )} - -happyReduce_99 = happySpecReduce_3 34# happyReduction_99 -happyReduction_99 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn41 - (ListName happy_var_2 - )} - -happyReduce_100 = happySpecReduce_1 35# happyReduction_100 -happyReduction_100 happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - happyIn42 - ((:[]) happy_var_1 - )} - -happyReduce_101 = happySpecReduce_3 35# happyReduction_101 -happyReduction_101 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut42 happy_x_3 of { happy_var_3 -> - happyIn42 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_102 = happySpecReduce_3 36# happyReduction_102 -happyReduction_102 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn43 - (LDDecl happy_var_1 happy_var_3 - )}} - -happyReduce_103 = happySpecReduce_3 36# happyReduction_103 -happyReduction_103 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn43 - (LDDef happy_var_1 happy_var_3 - )}} - -happyReduce_104 = happyReduce 5# 36# happyReduction_104 -happyReduction_104 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn43 - (LDFull happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_105 = happySpecReduce_0 37# happyReduction_105 -happyReduction_105 = happyIn44 - ([] - ) - -happyReduce_106 = happySpecReduce_1 37# happyReduction_106 -happyReduction_106 happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - happyIn44 - ((:[]) happy_var_1 - )} - -happyReduce_107 = happySpecReduce_3 37# happyReduction_107 -happyReduction_107 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - case happyOut44 happy_x_3 of { happy_var_3 -> - happyIn44 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_108 = happySpecReduce_1 38# happyReduction_108 -happyReduction_108 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn45 - (EPIdent happy_var_1 - )} - -happyReduce_109 = happySpecReduce_3 38# happyReduction_109 -happyReduction_109 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn45 - (EConstr happy_var_2 - )} - -happyReduce_110 = happySpecReduce_3 38# happyReduction_110 -happyReduction_110 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn45 - (ECons happy_var_2 - )} - -happyReduce_111 = happySpecReduce_1 38# happyReduction_111 -happyReduction_111 happy_x_1 - = case happyOut59 happy_x_1 of { happy_var_1 -> - happyIn45 - (ESort happy_var_1 - )} - -happyReduce_112 = happySpecReduce_1 38# happyReduction_112 -happyReduction_112 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn45 - (EString happy_var_1 - )} - -happyReduce_113 = happySpecReduce_1 38# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn45 - (EInt happy_var_1 - )} - -happyReduce_114 = happySpecReduce_1 38# happyReduction_114 -happyReduction_114 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn45 - (EFloat happy_var_1 - )} - -happyReduce_115 = happySpecReduce_1 38# happyReduction_115 -happyReduction_115 happy_x_1 - = happyIn45 - (EMeta - ) - -happyReduce_116 = happySpecReduce_2 38# happyReduction_116 -happyReduction_116 happy_x_2 - happy_x_1 - = happyIn45 - (EEmpty - ) - -happyReduce_117 = happySpecReduce_1 38# happyReduction_117 -happyReduction_117 happy_x_1 - = happyIn45 - (EData - ) - -happyReduce_118 = happyReduce 4# 38# happyReduction_118 -happyReduction_118 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut53 happy_x_3 of { happy_var_3 -> - happyIn45 - (EList happy_var_2 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_119 = happySpecReduce_3 38# happyReduction_119 -happyReduction_119 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn45 - (EStrings happy_var_2 - )} - -happyReduce_120 = happySpecReduce_3 38# happyReduction_120 -happyReduction_120 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut44 happy_x_2 of { happy_var_2 -> - happyIn45 - (ERecord happy_var_2 - )} - -happyReduce_121 = happySpecReduce_3 38# happyReduction_121 -happyReduction_121 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut67 happy_x_2 of { happy_var_2 -> - happyIn45 - (ETuple happy_var_2 - )} - -happyReduce_122 = happyReduce 4# 38# happyReduction_122 -happyReduction_122 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn45 - (EIndir happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_123 = happyReduce 5# 38# happyReduction_123 -happyReduction_123 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn45 - (ETyped happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_124 = happySpecReduce_3 38# happyReduction_124 -happyReduction_124 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn45 - (happy_var_2 - )} - -happyReduce_125 = happySpecReduce_1 38# happyReduction_125 -happyReduction_125 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn45 - (ELString happy_var_1 - )} - -happyReduce_126 = happySpecReduce_3 39# happyReduction_126 -happyReduction_126 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOut58 happy_x_3 of { happy_var_3 -> - happyIn46 - (EProj happy_var_1 happy_var_3 - )}} - -happyReduce_127 = happyReduce 5# 39# happyReduction_127 -happyReduction_127 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn46 - (EQConstr happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_128 = happyReduce 4# 39# happyReduction_128 -happyReduction_128 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn46 - (EQCons happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_129 = happySpecReduce_1 39# happyReduction_129 -happyReduction_129 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn46 - (happy_var_1 - )} - -happyReduce_130 = happySpecReduce_2 40# happyReduction_130 -happyReduction_130 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn47 - (EApp happy_var_1 happy_var_2 - )}} - -happyReduce_131 = happyReduce 4# 40# happyReduction_131 -happyReduction_131 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut70 happy_x_3 of { happy_var_3 -> - happyIn47 - (ETable happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_132 = happyReduce 5# 40# happyReduction_132 -happyReduction_132 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut45 happy_x_2 of { happy_var_2 -> - case happyOut70 happy_x_4 of { happy_var_4 -> - happyIn47 - (ETTable happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_133 = happyReduce 5# 40# happyReduction_133 -happyReduction_133 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut45 happy_x_2 of { happy_var_2 -> - case happyOut52 happy_x_4 of { happy_var_4 -> - happyIn47 - (EVTable happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_134 = happyReduce 6# 40# happyReduction_134 -happyReduction_134 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut70 happy_x_5 of { happy_var_5 -> - happyIn47 - (ECase happy_var_2 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_135 = happyReduce 4# 40# happyReduction_135 -happyReduction_135 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn47 - (EVariants happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_136 = happyReduce 6# 40# happyReduction_136 -happyReduction_136 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut74 happy_x_5 of { happy_var_5 -> - happyIn47 - (EPre happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_137 = happyReduce 4# 40# happyReduction_137 -happyReduction_137 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn47 - (EStrs happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_138 = happySpecReduce_2 40# happyReduction_138 -happyReduction_138 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn47 - (EPatt happy_var_2 - )} - -happyReduce_139 = happySpecReduce_3 40# happyReduction_139 -happyReduction_139 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_3 of { happy_var_3 -> - happyIn47 - (EPattType happy_var_3 - )} - -happyReduce_140 = happySpecReduce_1 40# happyReduction_140 -happyReduction_140 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn47 - (happy_var_1 - )} - -happyReduce_141 = happySpecReduce_2 40# happyReduction_141 -happyReduction_141 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn47 - (ELin happy_var_2 - )} - -happyReduce_142 = happySpecReduce_3 41# happyReduction_142 -happyReduction_142 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn48 - (ESelect happy_var_1 happy_var_3 - )}} - -happyReduce_143 = happySpecReduce_3 41# happyReduction_143 -happyReduction_143 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn48 - (ETupTyp happy_var_1 happy_var_3 - )}} - -happyReduce_144 = happySpecReduce_3 41# happyReduction_144 -happyReduction_144 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn48 - (EExtend happy_var_1 happy_var_3 - )}} - -happyReduce_145 = happySpecReduce_1 41# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn48 - (happy_var_1 - )} - -happyReduce_146 = happySpecReduce_3 42# happyReduction_146 -happyReduction_146 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_3 of { happy_var_3 -> - happyIn49 - (EGlue happy_var_1 happy_var_3 - )}} - -happyReduce_147 = happySpecReduce_1 42# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn49 - (happy_var_1 - )} - -happyReduce_148 = happySpecReduce_3 43# happyReduction_148 -happyReduction_148 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - (EConcat happy_var_1 happy_var_3 - )}} - -happyReduce_149 = happyReduce 4# 43# happyReduction_149 -happyReduction_149 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn50 - (EAbstr happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_150 = happyReduce 5# 43# happyReduction_150 -happyReduction_150 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_5 of { happy_var_5 -> - happyIn50 - (ECTable happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_151 = happySpecReduce_3 43# happyReduction_151 -happyReduction_151 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - (EProd happy_var_1 happy_var_3 - )}} - -happyReduce_152 = happySpecReduce_3 43# happyReduction_152 -happyReduction_152 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn50 - (ETType happy_var_1 happy_var_3 - )}} - -happyReduce_153 = happyReduce 6# 43# happyReduction_153 -happyReduction_153 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut44 happy_x_3 of { happy_var_3 -> - case happyOut50 happy_x_6 of { happy_var_6 -> - happyIn50 - (ELet happy_var_3 happy_var_6 - ) `HappyStk` happyRest}} - -happyReduce_154 = happyReduce 4# 43# happyReduction_154 -happyReduction_154 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut44 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn50 - (ELetb happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_155 = happyReduce 5# 43# happyReduction_155 -happyReduction_155 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut44 happy_x_4 of { happy_var_4 -> - happyIn50 - (EWhere happy_var_1 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_156 = happyReduce 4# 43# happyReduction_156 -happyReduction_156 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn50 - (EEqs happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_157 = happySpecReduce_3 43# happyReduction_157 -happyReduction_157 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - case happyOut8 happy_x_3 of { happy_var_3 -> - happyIn50 - (EExample happy_var_2 happy_var_3 - )}} - -happyReduce_158 = happySpecReduce_1 43# happyReduction_158 -happyReduction_158 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - happyIn50 - (happy_var_1 - )} - -happyReduce_159 = happySpecReduce_1 44# happyReduction_159 -happyReduction_159 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn51 - (happy_var_1 - )} - -happyReduce_160 = happySpecReduce_0 45# happyReduction_160 -happyReduction_160 = happyIn52 - ([] - ) - -happyReduce_161 = happySpecReduce_1 45# happyReduction_161 -happyReduction_161 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn52 - ((:[]) happy_var_1 - )} - -happyReduce_162 = happySpecReduce_3 45# happyReduction_162 -happyReduction_162 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut52 happy_x_3 of { happy_var_3 -> - happyIn52 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_163 = happySpecReduce_0 46# happyReduction_163 -happyReduction_163 = happyIn53 - (NilExp - ) - -happyReduce_164 = happySpecReduce_2 46# happyReduction_164 -happyReduction_164 happy_x_2 - happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_2 of { happy_var_2 -> - happyIn53 - (ConsExp happy_var_1 happy_var_2 - )}} - -happyReduce_165 = happySpecReduce_1 47# happyReduction_165 -happyReduction_165 happy_x_1 - = happyIn54 - (PChar - ) - -happyReduce_166 = happySpecReduce_3 47# happyReduction_166 -happyReduction_166 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn54 - (PChars happy_var_2 - )} - -happyReduce_167 = happySpecReduce_2 47# happyReduction_167 -happyReduction_167 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn54 - (PMacro happy_var_2 - )} - -happyReduce_168 = happyReduce 4# 47# happyReduction_168 -happyReduction_168 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_2 of { happy_var_2 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn54 - (PM happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_169 = happySpecReduce_1 47# happyReduction_169 -happyReduction_169 happy_x_1 - = happyIn54 - (PW - ) - -happyReduce_170 = happySpecReduce_1 47# happyReduction_170 -happyReduction_170 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn54 - (PV happy_var_1 - )} - -happyReduce_171 = happySpecReduce_3 47# happyReduction_171 -happyReduction_171 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn54 - (PCon happy_var_2 - )} - -happyReduce_172 = happySpecReduce_3 47# happyReduction_172 -happyReduction_172 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn54 - (PQ happy_var_1 happy_var_3 - )}} - -happyReduce_173 = happySpecReduce_1 47# happyReduction_173 -happyReduction_173 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn54 - (PInt happy_var_1 - )} - -happyReduce_174 = happySpecReduce_1 47# happyReduction_174 -happyReduction_174 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn54 - (PFloat happy_var_1 - )} - -happyReduce_175 = happySpecReduce_1 47# happyReduction_175 -happyReduction_175 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn54 - (PStr happy_var_1 - )} - -happyReduce_176 = happySpecReduce_3 47# happyReduction_176 -happyReduction_176 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut60 happy_x_2 of { happy_var_2 -> - happyIn54 - (PR happy_var_2 - )} - -happyReduce_177 = happySpecReduce_3 47# happyReduction_177 -happyReduction_177 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut68 happy_x_2 of { happy_var_2 -> - happyIn54 - (PTup happy_var_2 - )} - -happyReduce_178 = happySpecReduce_3 47# happyReduction_178 -happyReduction_178 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_2 of { happy_var_2 -> - happyIn54 - (happy_var_2 - )} - -happyReduce_179 = happySpecReduce_2 48# happyReduction_179 -happyReduction_179 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn55 - (PC happy_var_1 happy_var_2 - )}} - -happyReduce_180 = happyReduce 4# 48# happyReduction_180 -happyReduction_180 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - case happyOut61 happy_x_4 of { happy_var_4 -> - happyIn55 - (PQC happy_var_1 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_181 = happySpecReduce_2 48# happyReduction_181 -happyReduction_181 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn55 - (PRep happy_var_1 - )} - -happyReduce_182 = happySpecReduce_3 48# happyReduction_182 -happyReduction_182 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn55 - (PAs happy_var_1 happy_var_3 - )}} - -happyReduce_183 = happySpecReduce_2 48# happyReduction_183 -happyReduction_183 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn55 - (PNeg happy_var_2 - )} - -happyReduce_184 = happySpecReduce_1 48# happyReduction_184 -happyReduction_184 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn55 - (happy_var_1 - )} - -happyReduce_185 = happySpecReduce_3 49# happyReduction_185 -happyReduction_185 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn56 - (PDisj happy_var_1 happy_var_3 - )}} - -happyReduce_186 = happySpecReduce_3 49# happyReduction_186 -happyReduction_186 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn56 - (PSeq happy_var_1 happy_var_3 - )}} - -happyReduce_187 = happySpecReduce_1 49# happyReduction_187 -happyReduction_187 happy_x_1 - = case happyOut55 happy_x_1 of { happy_var_1 -> - happyIn56 - (happy_var_1 - )} - -happyReduce_188 = happySpecReduce_3 50# happyReduction_188 -happyReduction_188 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut56 happy_x_3 of { happy_var_3 -> - happyIn57 - (PA happy_var_1 happy_var_3 - )}} - -happyReduce_189 = happySpecReduce_1 51# happyReduction_189 -happyReduction_189 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn58 - (LPIdent happy_var_1 - )} - -happyReduce_190 = happySpecReduce_2 51# happyReduction_190 -happyReduction_190 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn58 - (LVar happy_var_2 - )} - -happyReduce_191 = happySpecReduce_1 52# happyReduction_191 -happyReduction_191 happy_x_1 - = happyIn59 - (Sort_Type - ) - -happyReduce_192 = happySpecReduce_1 52# happyReduction_192 -happyReduction_192 happy_x_1 - = happyIn59 - (Sort_PType - ) - -happyReduce_193 = happySpecReduce_1 52# happyReduction_193 -happyReduction_193 happy_x_1 - = happyIn59 - (Sort_Tok - ) - -happyReduce_194 = happySpecReduce_1 52# happyReduction_194 -happyReduction_194 happy_x_1 - = happyIn59 - (Sort_Str - ) - -happyReduce_195 = happySpecReduce_1 52# happyReduction_195 -happyReduction_195 happy_x_1 - = happyIn59 - (Sort_Strs - ) - -happyReduce_196 = happySpecReduce_0 53# happyReduction_196 -happyReduction_196 = happyIn60 - ([] - ) - -happyReduce_197 = happySpecReduce_1 53# happyReduction_197 -happyReduction_197 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - happyIn60 - ((:[]) happy_var_1 - )} - -happyReduce_198 = happySpecReduce_3 53# happyReduction_198 -happyReduction_198 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - happyIn60 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_199 = happySpecReduce_1 54# happyReduction_199 -happyReduction_199 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn61 - ((:[]) happy_var_1 - )} - -happyReduce_200 = happySpecReduce_2 54# happyReduction_200 -happyReduction_200 happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn61 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_201 = happySpecReduce_1 55# happyReduction_201 -happyReduction_201 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn62 - (BPIdent happy_var_1 - )} - -happyReduce_202 = happySpecReduce_1 55# happyReduction_202 -happyReduction_202 happy_x_1 - = happyIn62 - (BWild - ) - -happyReduce_203 = happySpecReduce_0 56# happyReduction_203 -happyReduction_203 = happyIn63 - ([] - ) - -happyReduce_204 = happySpecReduce_1 56# happyReduction_204 -happyReduction_204 happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - happyIn63 - ((:[]) happy_var_1 - )} - -happyReduce_205 = happySpecReduce_3 56# happyReduction_205 -happyReduction_205 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_3 of { happy_var_3 -> - happyIn63 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_206 = happyReduce 5# 57# happyReduction_206 -happyReduction_206 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn64 - (DDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_207 = happySpecReduce_1 57# happyReduction_207 -happyReduction_207 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn64 - (DExp happy_var_1 - )} - -happyReduce_208 = happySpecReduce_1 58# happyReduction_208 -happyReduction_208 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn65 - (TComp happy_var_1 - )} - -happyReduce_209 = happySpecReduce_1 59# happyReduction_209 -happyReduction_209 happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - happyIn66 - (PTComp happy_var_1 - )} - -happyReduce_210 = happySpecReduce_0 60# happyReduction_210 -happyReduction_210 = happyIn67 - ([] - ) - -happyReduce_211 = happySpecReduce_1 60# happyReduction_211 -happyReduction_211 happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - happyIn67 - ((:[]) happy_var_1 - )} - -happyReduce_212 = happySpecReduce_3 60# happyReduction_212 -happyReduction_212 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn67 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_213 = happySpecReduce_0 61# happyReduction_213 -happyReduction_213 = happyIn68 - ([] - ) - -happyReduce_214 = happySpecReduce_1 61# happyReduction_214 -happyReduction_214 happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - happyIn68 - ((:[]) happy_var_1 - )} - -happyReduce_215 = happySpecReduce_3 61# happyReduction_215 -happyReduction_215 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - case happyOut68 happy_x_3 of { happy_var_3 -> - happyIn68 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_216 = happySpecReduce_3 62# happyReduction_216 -happyReduction_216 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn69 - (Case happy_var_1 happy_var_3 - )}} - -happyReduce_217 = happySpecReduce_1 63# happyReduction_217 -happyReduction_217 happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn70 - ((:[]) happy_var_1 - )} - -happyReduce_218 = happySpecReduce_3 63# happyReduction_218 -happyReduction_218 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - case happyOut70 happy_x_3 of { happy_var_3 -> - happyIn70 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_219 = happySpecReduce_3 64# happyReduction_219 -happyReduction_219 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn71 - (Equ happy_var_1 happy_var_3 - )}} - -happyReduce_220 = happySpecReduce_0 65# happyReduction_220 -happyReduction_220 = happyIn72 - ([] - ) - -happyReduce_221 = happySpecReduce_1 65# happyReduction_221 -happyReduction_221 happy_x_1 - = case happyOut71 happy_x_1 of { happy_var_1 -> - happyIn72 - ((:[]) happy_var_1 - )} - -happyReduce_222 = happySpecReduce_3 65# happyReduction_222 -happyReduction_222 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut71 happy_x_1 of { happy_var_1 -> - case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn72 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_223 = happySpecReduce_3 66# happyReduction_223 -happyReduction_223 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - happyIn73 - (Alt happy_var_1 happy_var_3 - )}} - -happyReduce_224 = happySpecReduce_0 67# happyReduction_224 -happyReduction_224 = happyIn74 - ([] - ) - -happyReduce_225 = happySpecReduce_1 67# happyReduction_225 -happyReduction_225 happy_x_1 - = case happyOut73 happy_x_1 of { happy_var_1 -> - happyIn74 - ((:[]) happy_var_1 - )} - -happyReduce_226 = happySpecReduce_3 67# happyReduction_226 -happyReduction_226 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut73 happy_x_1 of { happy_var_1 -> - case happyOut74 happy_x_3 of { happy_var_3 -> - happyIn74 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_227 = happyReduce 5# 68# happyReduction_227 -happyReduction_227 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_4 of { happy_var_4 -> - happyIn75 - (DDDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_228 = happySpecReduce_1 68# happyReduction_228 -happyReduction_228 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn75 - (DDExp happy_var_1 - )} - -happyReduce_229 = happySpecReduce_0 69# happyReduction_229 -happyReduction_229 = happyIn76 - ([] - ) - -happyReduce_230 = happySpecReduce_2 69# happyReduction_230 -happyReduction_230 happy_x_2 - happy_x_1 - = case happyOut76 happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_2 of { happy_var_2 -> - happyIn76 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_231 = happySpecReduce_2 70# happyReduction_231 -happyReduction_231 happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn77 - (OldGr happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_232 = happySpecReduce_0 71# happyReduction_232 -happyReduction_232 = happyIn78 - (NoIncl - ) - -happyReduce_233 = happySpecReduce_2 71# happyReduction_233 -happyReduction_233 happy_x_2 - happy_x_1 - = case happyOut80 happy_x_2 of { happy_var_2 -> - happyIn78 - (Incl happy_var_2 - )} - -happyReduce_234 = happySpecReduce_1 72# happyReduction_234 -happyReduction_234 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn79 - (FString happy_var_1 - )} - -happyReduce_235 = happySpecReduce_1 72# happyReduction_235 -happyReduction_235 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn79 - (FPIdent happy_var_1 - )} - -happyReduce_236 = happySpecReduce_2 72# happyReduction_236 -happyReduction_236 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FSlash happy_var_2 - )} - -happyReduce_237 = happySpecReduce_2 72# happyReduction_237 -happyReduction_237 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FDot happy_var_2 - )} - -happyReduce_238 = happySpecReduce_2 72# happyReduction_238 -happyReduction_238 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FMinus happy_var_2 - )} - -happyReduce_239 = happySpecReduce_2 72# happyReduction_239 -happyReduction_239 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_2 of { happy_var_2 -> - happyIn79 - (FAddId happy_var_1 happy_var_2 - )}} - -happyReduce_240 = happySpecReduce_2 73# happyReduction_240 -happyReduction_240 happy_x_2 - happy_x_1 - = case happyOut79 happy_x_1 of { happy_var_1 -> - happyIn80 - ((:[]) happy_var_1 - )} - -happyReduce_241 = happySpecReduce_3 73# happyReduction_241 -happyReduction_241 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut79 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn80 - ((:) happy_var_1 happy_var_3 - )}} - -happyNewToken action sts stk [] = - happyDoAction 82# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS ";") -> cont 1#; - PT _ (TS "=") -> cont 2#; - PT _ (TS "{") -> cont 3#; - PT _ (TS "}") -> cont 4#; - PT _ (TS "**") -> cont 5#; - PT _ (TS ",") -> cont 6#; - PT _ (TS "(") -> cont 7#; - PT _ (TS ")") -> cont 8#; - PT _ (TS "[") -> cont 9#; - PT _ (TS "]") -> cont 10#; - PT _ (TS "-") -> cont 11#; - PT _ (TS ":") -> cont 12#; - PT _ (TS ".") -> cont 13#; - PT _ (TS "|") -> cont 14#; - PT _ (TS "%") -> cont 15#; - PT _ (TS "?") -> cont 16#; - PT _ (TS "<") -> cont 17#; - PT _ (TS ">") -> cont 18#; - PT _ (TS "!") -> cont 19#; - PT _ (TS "*") -> cont 20#; - PT _ (TS "+") -> cont 21#; - PT _ (TS "++") -> cont 22#; - PT _ (TS "\\") -> cont 23#; - PT _ (TS "->") -> cont 24#; - PT _ (TS "=>") -> cont 25#; - PT _ (TS "#") -> cont 26#; - PT _ (TS "_") -> cont 27#; - PT _ (TS "@") -> cont 28#; - PT _ (TS "$") -> cont 29#; - PT _ (TS "/") -> cont 30#; - PT _ (TS "Lin") -> cont 31#; - PT _ (TS "PType") -> cont 32#; - PT _ (TS "Str") -> cont 33#; - PT _ (TS "Strs") -> cont 34#; - PT _ (TS "Tok") -> cont 35#; - PT _ (TS "Type") -> cont 36#; - PT _ (TS "abstract") -> cont 37#; - PT _ (TS "case") -> cont 38#; - PT _ (TS "cat") -> cont 39#; - PT _ (TS "concrete") -> cont 40#; - PT _ (TS "data") -> cont 41#; - PT _ (TS "def") -> cont 42#; - PT _ (TS "flags") -> cont 43#; - PT _ (TS "fn") -> cont 44#; - PT _ (TS "fun") -> cont 45#; - PT _ (TS "grammar") -> cont 46#; - PT _ (TS "in") -> cont 47#; - PT _ (TS "include") -> cont 48#; - PT _ (TS "incomplete") -> cont 49#; - PT _ (TS "instance") -> cont 50#; - PT _ (TS "interface") -> cont 51#; - PT _ (TS "let") -> cont 52#; - PT _ (TS "lin") -> cont 53#; - PT _ (TS "lincat") -> cont 54#; - PT _ (TS "lindef") -> cont 55#; - PT _ (TS "lintype") -> cont 56#; - PT _ (TS "of") -> cont 57#; - PT _ (TS "open") -> cont 58#; - PT _ (TS "oper") -> cont 59#; - PT _ (TS "package") -> cont 60#; - PT _ (TS "param") -> cont 61#; - PT _ (TS "pattern") -> cont 62#; - PT _ (TS "pre") -> cont 63#; - PT _ (TS "printname") -> cont 64#; - PT _ (TS "resource") -> cont 65#; - PT _ (TS "reuse") -> cont 66#; - PT _ (TS "strs") -> cont 67#; - PT _ (TS "table") -> cont 68#; - PT _ (TS "tokenizer") -> cont 69#; - PT _ (TS "type") -> cont 70#; - PT _ (TS "union") -> cont 71#; - PT _ (TS "var") -> cont 72#; - PT _ (TS "variants") -> cont 73#; - PT _ (TS "where") -> cont 74#; - PT _ (TS "with") -> cont 75#; - PT _ (TI happy_dollar_dollar) -> cont 76#; - PT _ (TL happy_dollar_dollar) -> cont 77#; - PT _ (TD happy_dollar_dollar) -> cont 78#; - PT _ (T_PIdent _) -> cont 79#; - PT _ (T_LString happy_dollar_dollar) -> cont 80#; - _ -> cont 81#; - _ -> happyError' (tk:tks) - } - -happyError_ tk tks = happyError' (tk:tks) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = (thenM) -happyReturn :: () => a -> Err a -happyReturn = (returnM) -happyThen1 m k tks = (thenM) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (returnM) a -happyError' :: () => [Token] -> Err a -happyError' = happyError - -pGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut12 x)) - -pModDef tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut14 x)) - -pOldGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut77 x)) - -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut50 x)) - -happySeq = happyDontSeq - - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - -{-# LINE 28 "GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - -{-# LINE 49 "GenericTemplate.hs" #-} - -{-# LINE 59 "GenericTemplate.hs" #-} - -{-# LINE 68 "GenericTemplate.hs" #-} - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - -{-# LINE 127 "GenericTemplate.hs" #-} - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 170 "GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/src-3.0/GF/Devel/Compile/PrintGF.hs b/src-3.0/GF/Devel/Compile/PrintGF.hs deleted file mode 100644 index 7eb63612a..000000000 --- a/src-3.0/GF/Devel/Compile/PrintGF.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Devel.Compile.PrintGF where - --- pretty-printer generated by the BNF converter - -import GF.Devel.Compile.AbsGF -import Char - --- the top-level printing method -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - "[" :ts -> showChar '[' . rend i ts - "(" :ts -> showChar '(' . rend i ts - "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts - "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts - "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts - ";" :ts -> showChar ';' . new i . rend i ts - t : "," :ts -> showString t . space "," . rend i ts - t : ")" :ts -> showString t . showChar ')' . rend i ts - t : "]" :ts -> showString t . showChar ']' . rend i ts - t :ts -> space t . rend i ts - _ -> id - new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace - space t = showString t . (\s -> if null s then "" else (' ':s)) - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- the printer class does the job -class Print a where - prt :: Int -> a -> Doc - prtList :: [a] -> Doc - prtList = concatD . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') - prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q s = case s of - _ | s == q -> showChar '\\' . showChar s - '\\'-> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - _ -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - -instance Print LString where - prt _ (LString i) = doc (showString i) - - - -instance Print Grammar where - prt i e = case e of - Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs]) - - -instance Print ModDef where - prt i e = case e of - MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print ModType where - prt i e = case e of - MAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident]) - MResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident]) - MGrammar pident -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident]) - MInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident]) - MConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - MInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - - -instance Print ModBody where - prt i e = case e of - MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds]) - MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens]) - MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens]) - MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident]) - MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds]) - - -instance Print Extend where - prt i e = case e of - Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")]) - NoExt -> prPrec i 0 (concatD []) - - -instance Print Opens where - prt i e = case e of - NoOpens -> prPrec i 0 (concatD []) - OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")]) - - -instance Print Open where - prt i e = case e of - OName pident -> prPrec i 0 (concatD [prt 0 pident]) - OQual pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print ComplMod where - prt i e = case e of - CMCompl -> prPrec i 0 (concatD []) - CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")]) - - -instance Print Included where - prt i e = case e of - IAll pident -> prPrec i 0 (concatD [prt 0 pident]) - ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")]) - IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print TopDef where - prt i e = case e of - DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs]) - DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs]) - DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs]) - DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs]) - DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs]) - DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs]) - DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs]) - DefLincat defs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 defs]) - DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs]) - DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs]) - DefPrintCat defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 defs]) - DefPrintFun defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 defs]) - DefFlag defs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 defs]) - DefPrintOld defs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 defs]) - DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs]) - DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs]) - DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")]) - DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs]) - DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Def where - prt i e = case e of - DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) - DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp]) - DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp]) - DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print FunDef where - prt i e = case e of - FDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print CatDef where - prt i e = case e of - SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) - ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")]) - ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DataDef where - prt i e = case e of - DataDef name dataconstrs -> prPrec i 0 (concatD [prt 0 name , doc (showString "=") , prt 0 dataconstrs]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DataConstr where - prt i e = case e of - DataId pident -> prPrec i 0 (concatD [prt 0 pident]) - DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print ParDef where - prt i e = case e of - ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs]) - ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print ParConstr where - prt i e = case e of - ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print Name where - prt i e = case e of - PIdentName pident -> prPrec i 0 (concatD [prt 0 pident]) - ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print LocDef where - prt i e = case e of - LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp]) - LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp]) - LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Exp where - prt i e = case e of - EPIdent pident -> prPrec i 6 (concatD [prt 0 pident]) - EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) - ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")]) - ESort sort -> prPrec i 6 (concatD [prt 0 sort]) - EString str -> prPrec i 6 (concatD [prt 0 str]) - EInt n -> prPrec i 6 (concatD [prt 0 n]) - EFloat d -> prPrec i 6 (concatD [prt 0 d]) - EMeta -> prPrec i 6 (concatD [doc (showString "?")]) - EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")]) - EData -> prPrec i 6 (concatD [doc (showString "data")]) - EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")]) - EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")]) - ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")]) - EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")]) - ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")]) - EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label]) - EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")]) - EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) - EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp]) - ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")]) - ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")]) - EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")]) - ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")]) - EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")]) - EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")]) - EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")]) - EPatt patt -> prPrec i 4 (concatD [doc (showString "pattern") , prt 2 patt]) - EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , doc (showString "type") , prt 5 exp]) - ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp]) - ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp]) - EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp]) - EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp]) - EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp]) - EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp]) - ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp]) - EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp]) - ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp]) - ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp]) - ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp]) - EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")]) - EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")]) - EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str]) - ELString lstring -> prPrec i 6 (concatD [prt 0 lstring]) - ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Exps where - prt i e = case e of - NilExp -> prPrec i 0 (concatD []) - ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps]) - - -instance Print Patt where - prt i e = case e of - PChar -> prPrec i 2 (concatD [doc (showString "?")]) - PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident]) - PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) - PW -> prPrec i 2 (concatD [doc (showString "_")]) - PV pident -> prPrec i 2 (concatD [prt 0 pident]) - PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) - PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) - PInt n -> prPrec i 2 (concatD [prt 0 n]) - PFloat d -> prPrec i 2 (concatD [prt 0 d]) - PStr str -> prPrec i 2 (concatD [prt 0 str]) - PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")]) - PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")]) - PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts]) - PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts]) - PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt]) - PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt]) - PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")]) - PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt]) - PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt]) - - prtList es = case es of - [x] -> (concatD [prt 2 x]) - x:xs -> (concatD [prt 2 x , prt 0 xs]) - -instance Print PattAss where - prt i e = case e of - PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Label where - prt i e = case e of - LPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n]) - - -instance Print Sort where - prt i e = case e of - Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")]) - Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")]) - Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")]) - Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")]) - Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")]) - - -instance Print Bind where - prt i e = case e of - BPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - BWild -> prPrec i 0 (concatD [doc (showString "_")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Decl where - prt i e = case e of - DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) - DExp exp -> prPrec i 0 (concatD [prt 4 exp]) - - -instance Print TupleComp where - prt i e = case e of - TComp exp -> prPrec i 0 (concatD [prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print PattTupleComp where - prt i e = case e of - PTComp patt -> prPrec i 0 (concatD [prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Case where - prt i e = case e of - Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Equation where - prt i e = case e of - Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Altern where - prt i e = case e of - Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DDecl where - prt i e = case e of - DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) - DDExp exp -> prPrec i 0 (concatD [prt 6 exp]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print OldGrammar where - prt i e = case e of - OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs]) - - -instance Print Include where - prt i e = case e of - NoIncl -> prPrec i 0 (concatD []) - Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames]) - - -instance Print FileName where - prt i e = case e of - FString str -> prPrec i 0 (concatD [prt 0 str]) - FPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename]) - FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename]) - FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename]) - FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - - diff --git a/src-3.0/GF/Devel/Compile/Refresh.hs b/src-3.0/GF/Devel/Compile/Refresh.hs deleted file mode 100644 index 1708761fc..000000000 --- a/src-3.0/GF/Devel/Compile/Refresh.hs +++ /dev/null @@ -1,118 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Refresh --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:27 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- make variable names unique by adding an integer index to each ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Refresh ( - refreshModule, - refreshTerm, - refreshTermN - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad - - --- for concrete and resource in grammar, before optimizing - -refreshModule :: Int -> SourceModule -> Err (SourceModule,Int) -refreshModule k (m,mo) = do - (mo',(_,k')) <- appSTM (termOpModule refresh mo) (initIdStateN k) - return ((m,mo'),k') - - -refreshTerm :: Term -> Err Term -refreshTerm = refreshTermN 0 - -refreshTermN :: Int -> Term -> Err Term -refreshTermN i e = liftM snd $ refreshTermKN i e - -refreshTermKN :: Int -> Term -> Err (Int,Term) -refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (refresh e) (initIdStateN i) - -refresh :: Term -> STM IdState Term -refresh e = case e of - - Vr x -> liftM Vr (lookVar x) - Abs x b -> liftM2 Abs (refVarPlus x) (refresh b) - - Prod x a b -> do - a' <- refresh a - x' <- refVarPlus x - b' <- refresh b - return $ Prod x' a' b' - - Let (x,(mt,a)) b -> do - a' <- refresh a - mt' <- case mt of - Just t -> refresh t >>= (return . Just) - _ -> return mt - x' <- refVar x - b' <- refresh b - return (Let (x',(mt',a')) b') - - R r -> liftM R $ refreshRecord r - - ExtR r s -> liftM2 ExtR (refresh r) (refresh s) - - T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc) - - _ -> composOp refresh e - -refreshCase :: (Patt,Term) -> STM IdState (Patt,Term) -refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t) - -refreshPatt p = case p of - PV x -> liftM PV (refVarPlus x) - PC c ps -> liftM (PC c) (mapM refreshPatt ps) - PP q c ps -> liftM (PP q c) (mapM refreshPatt ps) - PR r -> liftM PR (mapPairsM refreshPatt r) - PT t p' -> liftM2 PT (refresh t) (refreshPatt p') - - PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p') - - PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q') - PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q') - PRep p' -> liftM PRep (refreshPatt p') - PNeg p' -> liftM PNeg (refreshPatt p') - - _ -> return p - -refreshRecord r = case r of - [] -> return r - (x,(mt,a)):b -> do - a' <- refresh a - mt' <- case mt of - Just t -> refresh t >>= (return . Just) - _ -> return mt - b' <- refreshRecord b - return $ (x,(mt',a')) : b' - -refreshTInfo i = case i of - TTyped t -> liftM TTyped $ refresh t - TComp t -> liftM TComp $ refresh t - TWild t -> liftM TWild $ refresh t - _ -> return i - --- for abstract syntax - -refreshEquation :: Equation -> Err ([Patt],Term) -refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where - refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t) - diff --git a/src-3.0/GF/Devel/Compile/Rename.hs b/src-3.0/GF/Devel/Compile/Rename.hs deleted file mode 100644 index 9ba704c19..000000000 --- a/src-3.0/GF/Devel/Compile/Rename.hs +++ /dev/null @@ -1,239 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Rename --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 18:39:44 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- AR 14\/5\/2003 --- The top-level function 'renameGrammar' does several things: --- --- - extends each module symbol table by indirections to extended module --- --- - changes unqualified and as-qualified imports to absolutely qualified --- --- - goes through the definitions and resolves names --- ------------------------------------------------------------------------------ - -module GF.Devel.Compile.Rename ( - renameModule - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident -import GF.Devel.Grammar.Lookup -import GF.Data.Operations - -import Control.Monad -import qualified Data.Map as Map -import Data.List (nub) -import Debug.Trace (trace) - -{- --- | this gives top-level access to renaming term input in the cc command -renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term -renameSourceTerm g m t = do - mo <- lookupErr m (modules g) - status <- buildStatus g m mo - renameTerm status [] t --} - -renameModule :: GF -> SourceModule -> Err SourceModule -renameModule gf sm@(name,mo) = case mtype mo of - MTInterface -> return sm - _ | not (isCompleteModule mo) -> return sm - _ -> errIn ("renaming module" +++ prt name) $ do - let gf1 = gf {gfmodules = Map.insert name mo (gfmodules gf)} - let rename = renameTerm (gf1,sm) [] - mo1 <- termOpModule rename mo - let mo2 = mo1 {mopens = nub [(i,i) | (_,i) <- mopens mo1]} - return (name,mo2) - -type RenameEnv = (GF,SourceModule) - -renameIdentTerm :: RenameEnv -> Term -> Err Term -renameIdentTerm (gf, (name,mo)) trm = case trm of - Vr i -> looks i - Con i -> looks i - Q m i -> getQualified m >>= look i - QC m i -> getQualified m >>= look i - _ -> return trm - where - looks i = do - let ts = nub [t | m <- pool, Ok t <- [look i m]] - case ts of - [t] -> return t - [] | elem i [IC "Int",IC "Float",IC "String"] -> ---- do this better - return (Q (IC "PredefAbs") i) - [] -> prtBad "identifier not found" i - t:_ -> - trace (unwords $ "WARNING":"identifier":prt i:"ambiguous:" : map prt ts) - (return t) ----- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts - look i m = do - ju <- lookupIdent gf m i - return $ case jform ju of - JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i - _ -> if isConstructor ju then QC m i else Q m i - pool = nub $ name : - maybe name id (interfaceName mo) : - IC "Predef" : - map fst (mextends mo) ++ - map snd (mopens mo) - getQualified m = case Map.lookup m qualifMap of - Just n -> return n - _ -> prtBad "unknown qualifier" m - qualifMap = Map.fromList $ - mopens mo ++ - concat [ops | (_,ops) <- minstances mo] ++ - [(m,m) | m <- pool] - ---- TODO: check uniqueness of these names - -renameTerm :: RenameEnv -> [Ident] -> Term -> Err Term -renameTerm env vars = ren vars where - ren vs trm = case trm of - Abs x b -> liftM (Abs x) (ren (x:vs) b) - Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) - Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x - | elem x vs -> return trm - | otherwise -> renid trm - Con _ -> renid trm - Q _ _ -> renid trm - QC _ _ -> renid trm - Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs - T i cs -> do - i' <- case i of - TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source - _ -> return i - liftM (T i') $ mapM (renCase vs) cs - - Let (x,(m,a)) b -> do - m' <- case m of - Just ty -> liftM Just $ ren vs ty - _ -> return m - a' <- ren vs a - b' <- ren (x:vs) b - return $ Let (x,(m',a')) b' - - P t@(Vr r) l -- for constant t we know it is projection - | elem r vs -> return trm -- var proj first - | otherwise -> case renid (Q r (label2ident l)) of -- qualif second - Ok t -> return t - _ -> case liftM (flip P l) $ renid t of - Ok t -> return t -- const proj last - _ -> prtBad "unknown qualified constant" trm - - EPatt p -> do - (p',_) <- renpatt p - return $ EPatt p' - - _ -> composOp (ren vs) trm - - renid = renameIdentTerm env - renCase vs (p,t) = do - (p',vs') <- renpatt p - t' <- ren (vs' ++ vs) t - return (p',t') - renpatt = renamePattern env - --- | vars not needed in env, since patterns always overshadow old vars -renamePattern :: RenameEnv -> Patt -> Err (Patt,[Ident]) -renamePattern env patt = case patt of - - PMacro c -> do - c' <- renid $ Vr c - case c' of - Q p d -> renp $ PM p d - _ -> prtBad "unresolved pattern" patt - - PC c ps -> do - c' <- renid $ Vr c - case c' of - QC p d -> renp $ PP p d ps - Q p d -> renp $ PP p d ps - _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) - - PP p c ps -> do - - (p', c') <- case renid (QC p c) of - Ok (QC p' c') -> return (p',c') - _ -> return (p,c) --- temporarily, for bw compat - psvss <- mapM renp ps - let (ps',vs) = unzip psvss - return (PP p' c' ps', concat vs) - - PV x -> case renid (Vr x) of - Ok (QC m c) -> return (PP m c [],[]) - _ -> return (patt, [x]) - - PR r -> do - let (ls,ps) = unzip r - psvss <- mapM renp ps - let (ps',vs') = unzip psvss - return (PR (zip ls ps'), concat vs') - - PAlt p q -> do - (p',vs) <- renp p - (q',ws) <- renp q - return (PAlt p' q', vs ++ ws) - - PSeq p q -> do - (p',vs) <- renp p - (q',ws) <- renp q - return (PSeq p' q', vs ++ ws) - - PRep p -> do - (p',vs) <- renp p - return (PRep p', vs) - - PNeg p -> do - (p',vs) <- renp p - return (PNeg p', vs) - - PAs x p -> do - (p',vs) <- renp p - return (PAs x p', x:vs) - - _ -> return (patt,[]) - - where - renp = renamePattern env - renid = renameIdentTerm env - -renameParam :: RenameEnv -> (Ident, Context) -> Err (Ident, Context) -renameParam env (c,co) = do - co' <- renameContext env co - return (c,co') - -renameContext :: RenameEnv -> Context -> Err Context -renameContext b = renc [] where - renc vs cont = case cont of - (x,t) : xts - | isWildIdent x -> do - t' <- ren vs t - xts' <- renc vs xts - return $ (x,t') : xts' - | otherwise -> do - t' <- ren vs t - let vs' = x:vs - xts' <- renc vs' xts - return $ (x,t') : xts' - _ -> return cont - ren = renameTerm b - --- | vars not needed in env, since patterns always overshadow old vars -renameEquation :: RenameEnv -> [Ident] -> Equation -> Err Equation -renameEquation b vs (ps,t) = do - (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps - t' <- renameTerm b (concat vs' ++ vs) t - return (ps',t') - diff --git a/src-3.0/GF/Devel/Compile/SourceToGF.hs b/src-3.0/GF/Devel/Compile/SourceToGF.hs deleted file mode 100644 index 3b7daa970..000000000 --- a/src-3.0/GF/Devel/Compile/SourceToGF.hs +++ /dev/null @@ -1,679 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SourceToGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/04 11:05:07 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.28 $ --- --- based on the skeleton Haskell module generated by the BNF converter ------------------------------------------------------------------------------ - -module GF.Devel.Compile.SourceToGF ( - transGrammar, - transModDef, - transExp, ----- transOldGrammar, ----- transInclude, - newReservedWords - ) where - -import qualified GF.Devel.Grammar.Grammar as G -import GF.Devel.Grammar.Construct -import qualified GF.Devel.Grammar.Macros as M -----import qualified GF.Compile.Update as U ---import qualified GF.Infra.Option as GO ---import qualified GF.Compile.ModDeps as GD -import GF.Infra.Ident -import GF.Devel.Compile.AbsGF -import GF.Devel.Compile.PrintGF (printTree) -----import GF.Source.PrintGF -----import GF.Compile.RemoveLiT --- for bw compat -import GF.Data.Operations ---import GF.Infra.Option - -import Control.Monad -import Data.Char -import qualified Data.Map as Map -import Data.List (genericReplicate) - -import Debug.Trace (trace) ---- - --- based on the skeleton Haskell module generated by the BNF converter - -type Result = Err String - -failure :: Show a => a -> Err b -failure x = Bad $ "Undefined case: " ++ show x - -getIdentPos :: PIdent -> Err (Ident,Int) -getIdentPos x = case x of - PIdent ((line,_),c) -> return (IC c,line) - -transIdent :: PIdent -> Err Ident -transIdent = liftM fst . getIdentPos - -transName :: Name -> Err Ident -transName n = case n of - PIdentName i -> transIdent i - ListName i -> transIdent (mkListId i) - -transGrammar :: Grammar -> Err G.GF -transGrammar x = case x of - Gr moddefs -> do - moddefs' <- mapM transModDef moddefs - let mos = Map.fromList moddefs' - return $ emptyGF {G.gfmodules = mos} - -transModDef :: ModDef -> Err (Ident, G.Module) -transModDef x = case x of - MModule compl mtyp body -> do - - let isCompl = transComplMod compl - - (trDef, mtyp', id') <- case mtyp of - MAbstract id -> do - id' <- transIdent id - return (transAbsDef, G.MTAbstract, id') - MGrammar id -> mkModRes id G.MTGrammar body - MResource id -> mkModRes id G.MTGrammar body - MConcrete id open -> do - id' <- transIdent id - open' <- transIdent open - return (transCncDef, G.MTConcrete open', id') - MInterface id -> mkModRes id G.MTInterface body - MInstance id open -> do - open' <- transIdent open - mkModRes id (G.MTInstance open') body - - mkBody (isCompl, trDef, mtyp', id') body - where - mkBody xx@(isc, trDef, mtyp', id') bod = case bod of - MNoBody incls -> do - mkBody xx $ MBody (Ext incls) NoOpens [] - MBody extends opens defs -> do - extends' <- transExtend extends - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - let defs' = Map.fromListWith unifyJudgements - [(i,d) | Left ds <- defs0, (i,d) <- ds] - let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', G.Module mtyp' isc [] [] extends' opens' flags' defs') - - MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] - MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs - MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens [] - MWithEBody extends m insts opens defs -> do - extends' <- mapM transIncludedExt extends - m' <- transIncludedExt m - insts' <- mapM transOpen insts - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - let defs' = Map.fromListWith unifyJudgements - [(i,d) | Left ds <- defs0, (i,d) <- ds] - let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', G.Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') - _ -> fail "deprecated module form" - - - mkModRes id mtyp body = do - id' <- transIdent id - return (transResDef, mtyp, id') - - -getTopDefs :: [TopDef] -> [TopDef] -getTopDefs x = x - -transComplMod :: ComplMod -> Bool -transComplMod x = case x of - CMCompl -> True - CMIncompl -> False - -transExtend :: Extend -> Err [(Ident,G.MInclude)] -transExtend x = case x of - Ext ids -> mapM transIncludedExt ids - NoExt -> return [] - -transOpens :: Opens -> Err [(Ident,Ident)] -transOpens x = case x of - NoOpens -> return [] - OpenIn opens -> mapM transOpen opens - -transOpen :: Open -> Err (Ident,Ident) -transOpen x = case x of - OName id -> transIdent id >>= \y -> return (y,y) - OQual id m -> liftM2 (,) (transIdent id) (transIdent m) - -transIncludedExt :: Included -> Err (Ident, G.MInclude) -transIncludedExt x = case x of - IAll i -> liftM2 (,) (transIdent i) (return G.MIAll) - ISome i ids -> liftM2 (,) (transIdent i) (liftM G.MIOnly $ mapM transIdent ids) - IMinus i ids -> liftM2 (,) (transIdent i) (liftM G.MIExcept $ mapM transIdent ids) - -transAbsDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) -transAbsDef x = case x of - DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs - DefFun fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl [(fun, absFun typ) | (funs,typ) <- fundefs', fun <- funs] -{- ---- - DefFunData fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl $ - [(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs', - fun <- funs, - Ok (_,cat) <- [M.valCat typ] - ] ++ - [(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] - DefDef defs -> do - defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] - DefData ds -> do - ds' <- mapM transDataDef ds - returnl $ - [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ - [(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] --} - DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs - _ -> return $ Left [] ---- ----- _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x - where - -- to get data constructors as terms - funs t = case t of - G.Con f -> [f] - G.Q _ f -> [f] - G.QC _ f -> [f] - _ -> [] - -returnl :: a -> Err (Either a b) -returnl = return . Left - -transFlagDef :: Def -> Err [(Ident,String)] -transFlagDef x = case x of - DDef f x -> do - fs <- mapM transName f - x' <- transExp x - v <- case x' of - G.K s -> return s - G.Vr (IC s) -> return s - G.EInt i -> return $ show i - _ -> fail $ "illegal flag value" +++ printTree x - return $ [(f',v) | f' <- fs] - - --- | Cat definitions can also return some fun defs --- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, G.Judgement)] -transCatDef x = case x of - SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls - ListCatDef id ddecls -> listCat id ddecls 0 - ListSizeCatDef id ddecls size -> listCat id ddecls size - where - cat id ddecls = do - i <- transIdent id - cont <- liftM concat $ mapM transDDecl ddecls - return (i, absCat cont) - listCat id ddecls size = do - let li = mkListId id - li' <- transIdent $ li - baseId <- transIdent $ mkBaseId id - consId <- transIdent $ mkConsId id - catd0@(c,ju) <- cat li ddecls - id' <- transIdent id - let - cont0 = [] ---- cat context - catd = (c,ju) ----(Yes cont0) (Yes [M.cn baseId,M.cn consId])) - cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0] - xs = map (G.Vr . fst) cont - cd = M.mkDecl (M.mkApp (G.Vr id') xs) - lc = M.mkApp (G.Vr li') xs - niltyp = mkProd (cont ++ genericReplicate size cd) lc - nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) - constyp = mkProd (cont ++ [cd, M.mkDecl lc]) lc - consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData)) - return [catd,nilfund,consfund] - mkId x i = if isWildIdent x then (identV "x" i) else x - -transFunDef :: FunDef -> Err ([Ident], G.Type) -transFunDef x = case x of - FDecl ids typ -> liftM2 (,) (mapM transName ids) (transExp typ) - -{- ---- -transDataDef :: DataDef -> Err (Ident,[G.Term]) -transDataDef x = case x of - DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds) - where - transData d = case d of - DataId id -> liftM G.Con $ transIdent id - DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) --} - -transResDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) -transResDef x = case x of - DefPar pardefs -> do - pardefs' <- mapM transParDef pardefs - returnl $ concatMap mkParamDefs pardefs' - - DefOper defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl $ concatMap mkOverload [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] - - DefLintype defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, resOper pt pe) | (f,(pt,pe)) <- defs'] - - DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs - _ -> return $ Left [] ---- ----- _ -> Bad $ "illegal definition form in resource" +++ printTree x - where - - mkParamDefs (p,pars) = - if null pars - then [(p,addJType M.meta0 (emptyJudgement G.JParam))] -- in an interface - else (p,resParam p pars) : paramConstructors p pars - - mkOverload (c,j) = case (G.jtype j, G.jdef j) of - (_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs -> - [(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] - - -- to enable separare type signature --- not type-checked - (G.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> [] - _ -> [(c,j)] - isOverloading (G.Vr keyw) c fs = - prIdent keyw == "overload" && -- overload is a "soft keyword" - True ---- all (== GP.prt c) (map (GP.prt . fst) fs) - -transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)]) -transParDef x = case x of - ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) - ParDefAbs id -> liftM2 (,) (transIdent id) (return []) - -transCncDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) -transCncDef x = case x of - DefLincat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, cncCat t) | (f,t) <- defs'] ----- DefLindef defs -> do ----- defs' <- liftM concat $ mapM getDefs defs ----- returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] - DefLin defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, cncFun pe) | (f,(_,pe)) <- defs'] -{- ---- - DefPrintCat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] - DefPrintFun defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] - DefPrintOld defs -> do --- a guess, for backward compatibility - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] - DefFlag defs -> liftM Right $ mapM transFlagDef defs - DefPattern defs -> do - defs' <- liftM concat $ mapM getDefs defs - let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] - returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] --} - _ -> return $ Left [] ---- ----- _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x - -transPrintDef :: Def -> Err [(Ident,G.Term)] -transPrintDef x = case x of - DDef ids exp -> do - (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) - return $ [(i,e) | i <- ids] - -getDefsGen :: Def -> Err [(Ident, (G.Type, G.Term))] -getDefsGen d = case d of - DDecl ids t -> do - ids' <- mapM transName ids - t' <- transExp t - return [(i,(t', nope)) | i <- ids'] - DDef ids e -> do - ids' <- mapM transName ids - e' <- transExp e - return [(i,(nope, yes e')) | i <- ids'] - DFull ids t e -> do - ids' <- mapM transName ids - t' <- transExp t - e' <- transExp e - return [(i,(yes t', yes e')) | i <- ids'] - DPatt id patts e -> do - id' <- transName id - ps' <- mapM transPatt patts - e' <- transExp e - return [(id',(nope, yes (G.Eqs [(ps',e')])))] - where - yes = id - nope = G.Meta 0 - --- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [(Ident, (G.Type, G.Term))] -getDefs d = case d of - DPatt id patts e -> do - id' <- transName id - xs <- mapM tryMakeVar patts - e' <- transExp e - return [(id',(nope, (M.mkAbs xs e')))] - _ -> getDefsGen d - where - nope = G.Meta 0 - --- | accepts a pattern that is either a variable or a wild card -tryMakeVar :: Patt -> Err Ident -tryMakeVar p = do - p' <- transPatt p - case p' of - G.PV i -> return i - G.PW -> return identW - _ -> Bad $ "not a legal pattern in lambda binding" +++ show p' - -transExp :: Exp -> Err G.Term -transExp x = case x of - EPIdent id -> liftM G.Vr $ transIdent id - EConstr id -> liftM G.Con $ transIdent id - ECons id -> liftM G.Con $ transIdent id - EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c) - EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c) - EString str -> return $ G.K str - ESort sort -> liftM G.Sort $ transSort sort - EInt n -> return $ G.EInt n - EFloat n -> return $ G.EFloat n - EMeta -> return $ G.Meta 0 - EEmpty -> return G.Empty - -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n) - EList i es -> transExp $ foldl EApp (EPIdent (mkListId i)) (exps2list es) - EStrings [] -> return G.Empty - EStrings str -> return $ foldr1 G.C $ map G.K $ words str - ERecord defs -> erecord2term defs - ETupTyp _ _ -> do - let tups t = case t of - ETupTyp x y -> tups x ++ [y] -- right-associative parsing - _ -> [t] - es <- mapM transExp $ tups x - return $ G.RecType $ M.tuple2recordType es - ETuple tuplecomps -> do - es <- mapM transExp [e | TComp e <- tuplecomps] - return $ G.R $ M.tuple2record es - EProj exp id -> liftM2 G.P (transExp exp) (trLabel id) - EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp) - ETable cases -> liftM (G.T G.TRaw) (transCases cases) - ETTable exp cases -> - liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases) - EVTable exp cases -> - liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases) - ECase exp cases -> do - exp' <- transExp exp - cases' <- transCases cases - let annot = case exp' of - G.Typed _ t -> G.TTyped t - _ -> G.TRaw - return $ G.S (G.T annot cases') exp' - ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) - - EVariants exps -> liftM G.FV $ mapM transExp exps - EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts) - EStrs exps -> liftM G.FV $ mapM transExp exps - ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp) - EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp) - EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp) - ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp) - EExample exp str -> liftM2 G.Example (transExp exp) (return str) - - EProd decl exp -> liftM2 mkProd (transDecl decl) (transExp exp) - ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp) - EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp) - EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp) - ELet defs exp -> do - exp' <- transExp exp - defs0 <- mapM locdef2fields defs - defs' <- mapM tryLoc $ concat defs0 - return $ M.mkLet defs' exp' - where - tryLoc (c,(mty,Just e)) = return (c,(mty,e)) - tryLoc (c,_) = Bad $ "local definition of" +++ prIdent c +++ "without value" - ELetb defs exp -> transExp $ ELet defs exp - EWhere exp defs -> transExp $ ELet defs exp - - EPattType typ -> liftM G.EPattType (transExp typ) - EPatt patt -> liftM G.EPatt (transPatt patt) - - ELString (LString str) -> return $ G.K str ----- ELin id -> liftM G.LiT $ transIdent id - - EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs - EData -> return G.EData - - _ -> Bad $ "translation not yet defined for" +++ printTree x ---- - -exps2list :: Exps -> [Exp] -exps2list NilExp = [] -exps2list (ConsExp e es) = e : exps2list es - ---- this is complicated: should we change Exp or G.Term ? - -erecord2term :: [LocDef] -> Err G.Term -erecord2term ds = do - ds' <- mapM locdef2fields ds - mkR $ concat ds' - where - mkR fs = do - fs' <- transF fs - return $ case fs' of - Left ts -> G.RecType ts - Right ds -> G.R ds - transF [] = return $ Left [] --- empty record always interpreted as record type - transF fs@(f:_) = case f of - (lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left - _ -> mapM tryR fs >>= return . Right - tryRT f = case f of - (lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty) - _ -> Bad $ "illegal record type field" +++ show (fst f) --- manifest fields ?! - tryR f = case f of - (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) - _ -> Bad $ "illegal record field" +++ show (fst f) - - -locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))] -locdef2fields d = case d of - LDDecl ids t -> do - labs <- mapM transIdent ids - t' <- transExp t - return [(lab,(Just t',Nothing)) | lab <- labs] - LDDef ids e -> do - labs <- mapM transIdent ids - e' <- transExp e - return [(lab,(Nothing, Just e')) | lab <- labs] - LDFull ids t e -> do - labs <- mapM transIdent ids - t' <- transExp t - e' <- transExp e - return [(lab,(Just t', Just e')) | lab <- labs] - -trLabel :: Label -> Err G.Label -trLabel x = case x of - - -- this case is for bward compatibiity and should be removed - LPIdent (PIdent (_,'v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds - - LPIdent (PIdent (_, s)) -> return $ G.LIdent s - LVar x -> return $ G.LVar $ fromInteger x - -transSort :: Sort -> Err String -transSort x = case x of - _ -> return $ printTree x - -transPatt :: Patt -> Err G.Patt -transPatt x = case x of - PChar -> return G.PChar - PChars s -> return $ G.PChars s - PMacro c -> liftM G.PMacro $ transIdent c - PM m c -> liftM2 G.PM (transIdent m) (transIdent c) - PW -> return wildPatt - PV (PIdent (_,"_")) -> return wildPatt - PV id -> liftM G.PV $ transIdent id - PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts) - PCon id -> liftM2 G.PC (transIdent id) (return []) - PInt n -> return $ G.PInt n - PFloat n -> return $ G.PFloat n - PStr str -> return $ G.PString str - PR pattasss -> do - let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] - ls = map LPIdent $ concat lss - liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps) - PTup pcs -> - liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs]) - PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return []) - PQC id0 id patts -> - liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts) - PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2) - PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2) - PRep p -> liftM G.PRep (transPatt p) - PNeg p -> liftM G.PNeg (transPatt p) - PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p) - - - -transBind :: Bind -> Err Ident -transBind x = case x of - BPIdent (PIdent (_,"_")) -> return identW - BPIdent id -> transIdent id - BWild -> return identW - -transDecl :: Decl -> Err [G.Decl] -transDecl x = case x of - DDec binds exp -> do - xs <- mapM transBind binds - exp' <- transExp exp - return [(x,exp') | x <- xs] - DExp exp -> liftM (return . M.mkDecl) $ transExp exp - -transCases :: [Case] -> Err [G.Case] -transCases = mapM transCase - -transCase :: Case -> Err G.Case -transCase (Case p exp) = do - patt <- transPatt p - exp' <- transExp exp - return (patt,exp') - -transEquation :: Equation -> Err G.Equation -transEquation x = case x of - Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp) - -transAltern :: Altern -> Err (G.Term, G.Term) -transAltern x = case x of - Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp) - -transParConstr :: ParConstr -> Err (Ident,G.Context) -transParConstr x = case x of - ParConstr id ddecls -> do - id' <- transIdent id - ddecls' <- mapM transDDecl ddecls - return (id',concat ddecls') - -transDDecl :: DDecl -> Err [G.Decl] -transDDecl x = case x of - DDDec binds exp -> transDecl $ DDec binds exp - DDExp exp -> transDecl $ DExp exp - -{- ---- --- | to deal with the old format, sort judgements in three modules, forming --- their names from a given string, e.g. file name or overriding user-given string -transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar -transOldGrammar opts name0 x = case x of - OldGr includes topdefs -> do --- includes must be collected separately - let moddefs = sortTopDefs topdefs - g1 <- transGrammar $ Gr moddefs - removeLiT g1 --- needed for bw compatibility with an obsolete feature - where - sortTopDefs ds = [mkAbs a,mkRes ops r,mkCnc ops c] ++ map mkPack ps - where - ops = map fst ps - (a,r,c,ps) = foldr srt ([],[],[],[]) ds - srt d (a,r,c,ps) = case d of - DefCat catdefs -> (d:a,r,c,ps) - DefFun fundefs -> (d:a,r,c,ps) - DefFunData fundefs -> (d:a,r,c,ps) - DefDef defs -> (d:a,r,c,ps) - DefData pardefs -> (d:a,r,c,ps) - DefPar pardefs -> (a,d:r,c,ps) - DefOper defs -> (a,d:r,c,ps) - DefLintype defs -> (a,d:r,c,ps) - DefLincat defs -> (a,r,d:c,ps) - DefLindef defs -> (a,r,d:c,ps) - DefLin defs -> (a,r,d:c,ps) - DefPattern defs -> (a,r,d:c,ps) - DefFlag defs -> (a,r,d:c,ps) --- a guess - DefPrintCat printdefs -> (a,r,d:c,ps) - DefPrintFun printdefs -> (a,r,d:c,ps) - DefPrintOld printdefs -> (a,r,d:c,ps) - DefPackage m ds -> (a,r,c,(m,ds):ps) - _ -> (a,r,c,ps) - mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a)) - mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r)) - where ops = map OName ps - mkCnc ps r = MModule q (MTConcrete cncName absName) - (MBody ne (OpenIn (map OName (resName:ps))) (topDefs r)) - mkPack (m, ds) = MModule q (MTResource m) (MBody ne (OpenIn []) (topDefs ds)) - topDefs t = t - ne = NoExt - q = CMCompl - - name = maybe name0 (++ ".gf") $ getOptVal opts useName - absName = identC $ maybe topic id $ getOptVal opts useAbsName - resName = identC $ maybe ("Res" ++ lang) id $ getOptVal opts useResName - cncName = identC $ maybe lang id $ getOptVal opts useCncName - - (beg,rest) = span (/='.') name - (topic,lang) = case rest of -- to avoid overwriting old files - ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".cf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg) - [] -> ("Abs" ++ beg,"Cnc" ++ beg) - _:s -> (beg, takeWhile (/='.') s) - -transInclude :: Include -> Err [FilePath] -transInclude x = case x of - NoIncl -> return [] - Incl filenames -> return $ map trans filenames - where - trans f = case f of - FString s -> s - FIdent (IC s) -> modif s - FSlash filename -> '/' : trans filename - FDot filename -> '.' : trans filename - FMinus filename -> '-' : trans filename - FAddId (IC s) filename -> modif s ++ trans filename - modif s = let s' = init s ++ [toLower (last s)] in - if elem s' newReservedWords then s' else s - --- unsafe hack ; cf. GetGrammar.oldLexer --} - -newReservedWords :: [String] -newReservedWords = - words $ "abstract concrete interface incomplete " ++ - "instance out open resource reuse transfer union with where" - -termInPattern :: G.Term -> G.Term -termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where - toP t = case t of - G.Vr x -> G.P t s - _ -> M.composSafeOp toP t - s = G.LIdent "s" - (xx,body) = abss [] t - abss xs t = case t of - G.Abs x b -> abss (x:xs) b - _ -> (reverse xs,t) - -mkListId,mkConsId,mkBaseId :: PIdent -> PIdent -mkListId = prefixId "List" -mkConsId = prefixId "Cons" -mkBaseId = prefixId "Base" - -prefixId :: String -> PIdent -> PIdent -prefixId pref (PIdent (p,id)) = PIdent (p, pref ++ id) diff --git a/src-3.0/GF/Devel/GFC/Main.hs b/src-3.0/GF/Devel/GFC/Main.hs deleted file mode 100644 index d9ceb8e70..000000000 --- a/src-3.0/GF/Devel/GFC/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ -module GF.Devel.GFC.Main where - -import GF.Devel.GFC.Options - -import System.Environment -import System.Exit -import System.IO - - -version = "X.X" - -main :: IO () -main = - do args <- getArgs - case parseOptions args of - Ok (opts, files) -> - case optMode opts of - Version -> putStrLn $ "GF, version " ++ version - Help -> putStr helpMessage - Compiler -> gfcMain opts files - Errors errs -> - do mapM_ (hPutStrLn stderr) errs - exitFailure - -gfcMain :: Options -> [FilePath] -> IO () -gfcMain opts files = return () - - diff --git a/src-3.0/GF/Devel/GFCCInterpreter.hs b/src-3.0/GF/Devel/GFCCInterpreter.hs deleted file mode 100644 index b2b17dba7..000000000 --- a/src-3.0/GF/Devel/GFCCInterpreter.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Main where - -import GF.Command.Interpreter -import GF.Command.Commands -import GF.GFCC.API -import System (getArgs) -import Data.Char (isDigit) - --- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007 - -main :: IO () -main = do - file:_ <- getArgs - grammar <- file2grammar file - let env = CommandEnv grammar (allCommands grammar) - printHelp grammar - loop env - -loop :: CommandEnv -> IO () -loop env = do - s <- getLine - if s == "q" then return () else do - interpretCommandLine env s - loop env - -printHelp grammar = do - putStrLn $ "languages: " ++ unwords (languages grammar) - putStrLn $ "categories: " ++ unwords (categories grammar) diff --git a/src-3.0/GF/Devel/Grammar/AppPredefined.hs b/src-3.0/GF/Devel/Grammar/AppPredefined.hs deleted file mode 100644 index 2c07b0d83..000000000 --- a/src-3.0/GF/Devel/Grammar/AppPredefined.hs +++ /dev/null @@ -1,166 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AppPredefined --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/06 14:21:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- Predefined function type signatures and definitions. ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.AppPredefined ( - isInPredefined, - typPredefined, - appPredefined - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF (prt,prt_,prtBad) -import GF.Infra.Ident - -import GF.Data.Operations - - --- predefined function type signatures and definitions. AR 12/3/2003. - -isInPredefined :: Ident -> Bool -isInPredefined = err (const True) (const False) . typPredefined - -typPredefined :: Ident -> Err Type -typPredefined c@(IC f) = case f of - "Int" -> return typePType - "Float" -> return typePType - "Error" -> return typeType - "Ints" -> return $ mkFunType [cnPredef "Int"] typePType - "PBool" -> return typePType - "error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set - "PFalse" -> return $ cnPredef "PBool" - "PTrue" -> return $ cnPredef "PBool" - "dp" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - "drop" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - "eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool") - "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool") - "eqStr" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool") - "length" -> return $ mkFunType [typeStr] (cnPredef "Int") - "occur" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool") - "occurs" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool") - "plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int") ----- "read" -> (P : Type) -> Tok -> P - "show" -> return $ mkProds -- (P : PType) -> P -> Tok - ([(identC "P",typePType),(identW,Vr (identC "P"))],typeStr,[]) - "toStr" -> return $ mkProds -- (L : Type) -> L -> Str - ([(identC "L",typeType),(identW,Vr (identC "L"))],typeStr,[]) - "mapStr" -> - let ty = identC "L" in - return $ mkProds -- (L : Type) -> (Str -> Str) -> L -> L - ([(ty,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr ty)],Vr ty,[]) - "take" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - "tk" -> return $ mkFunType [cnPredef "Int",typeStr] typeStr - _ -> prtBad "unknown in Predef:" c - -typPredefined c = prtBad "unknown in Predef:" c - -mkProds (cont,t,xx) = foldr (uncurry Prod) (mkApp t xx) cont - -appPredefined :: Term -> Err (Term,Bool) -appPredefined t = case t of - - App f x0 -> do - (x,_) <- appPredefined x0 - case f of - -- one-place functions - Q (IC "Predef") (IC f) -> case (f, x) of - ("length", K s) -> retb $ EInt $ toInteger $ length s - _ -> retb t ---- prtBad "cannot compute predefined" t - - -- two-place functions - App (Q (IC "Predef") (IC f)) z0 -> do - (z,_) <- appPredefined z0 - case (f, norm z, norm x) of - ("drop", EInt i, K s) -> retb $ K (drop (fi i) s) - ("take", EInt i, K s) -> retb $ K (take (fi i) s) - ("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s) - ("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s) - ("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse - ("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse - ("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse - ("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse - ("lessInt",EInt i, EInt j) -> retb $ if i retb $ EInt $ i+j - ("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t - ("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags - ("toStr", _, t) -> trm2str t >>= retb - - _ -> retb t ---- prtBad "cannot compute predefined" t - - -- three-place functions - App (App (Q (IC "Predef") (IC f)) z0) y0 -> do - (y,_) <- appPredefined y0 - (z,_) <- appPredefined z0 - case (f, z, y, x) of - ("mapStr",ty,op,t) -> retf $ mapStr ty op t - _ -> retb t ---- prtBad "cannot compute predefined" t - - _ -> retb t ---- prtBad "cannot compute predefined" t - _ -> retb t - ---- should really check the absence of arg variables - where - retb t = return (t,True) -- no further computing needed - retf t = return (t,False) -- must be computed further - norm t = case t of - Empty -> K [] - _ -> t - fi = fromInteger - --- read makes variables into constants - -str2tag :: String -> Term -str2tag s = case s of ----- '\'' : cs -> mkCn $ pTrm $ init cs - _ -> Con $ IC s --- - where - mkCn t = case t of - Vr i -> Con i - App c a -> App (mkCn c) (mkCn a) - _ -> t - - -predefTrue = Q (IC "Predef") (IC "PTrue") -predefFalse = Q (IC "Predef") (IC "PFalse") - -substring :: String -> String -> Bool -substring s t = case (s,t) of - (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds - ([],_) -> True - _ -> False - -trm2str :: Term -> Err Term -trm2str t = case t of - R ((_,(_,s)):_) -> trm2str s - T _ ((_,s):_) -> trm2str s - V _ (s:_) -> trm2str s - C _ _ -> return $ t - K _ -> return $ t - S c _ -> trm2str c - Empty -> return $ t - _ -> prtBad "cannot get Str from term" t - --- simultaneous recursion on type and term: type arg is essential! --- But simplify the task by assuming records are type-annotated --- (this has been done in type checking) -mapStr :: Type -> Term -> Term -> Term -mapStr ty f t = case (ty,t) of - _ | elem ty [typeStr,typeStr] -> App f t - (_, R ts) -> R [(l,mapField v) | (l,v) <- ts] - (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs] - _ -> t - where - mapField (mty,te) = case mty of - Just ty -> (mty,mapStr ty f te) - _ -> (mty,te) diff --git a/src-3.0/GF/Devel/Grammar/Compute.hs b/src-3.0/GF/Devel/Grammar/Compute.hs deleted file mode 100644 index 5e465c160..000000000 --- a/src-3.0/GF/Devel/Grammar/Compute.hs +++ /dev/null @@ -1,380 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.Compute ( - computeTerm, - computeTermCont, - computeTermRec - ) where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.Lookup -import GF.Devel.Grammar.PrGF -import GF.Devel.Grammar.PatternMatch -import GF.Devel.Grammar.AppPredefined - -import GF.Infra.Ident -import GF.Infra.Option - ---import GF.Grammar.Refresh ---import GF.Grammar.Lockfield (isLockLabel) ---- - -import GF.Data.Str ---- -import GF.Data.Operations - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) - --- | computation of concrete syntax terms into normal form --- used mainly for partial evaluation -computeTerm :: GF -> Term -> Err Term -computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t -computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t - -computeTermCont :: GF -> Substitution -> Term -> Err Term -computeTermCont = computeTermOpt False - --- rec=True is used if it cannot be assumed that looked-up constants --- have already been computed (mainly with -optimize=noexpand in .gfr) - -computeTermOpt :: Bool -> GF -> Substitution -> Term -> Err Term -computeTermOpt rec gr = comp where - - comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging - case t of - - Q (IC "Predef") _ -> return t - Q p c -> look p c - - -- if computed do nothing - ---- Computed t' -> return $ unComputed t' - - Vr x -> do - t' <- maybe (prtBad ("no value for variable") x) return $ lookup x g - case t' of - _ | t == t' -> return t - _ -> comp g t' - - Abs x b -> do - b' <- comp (ext x (Vr x) g) b - return $ Abs x b' - - Let (x,(_,a)) b -> do - a' <- comp g a - comp (ext x a' g) b - - Prod x a b -> do - a' <- comp g a - b' <- comp (ext x (Vr x) g) b - return $ Prod x a' b' - - -- beta-convert - App f a -> do - f' <- comp g f - a' <- comp g a - case (f',a') of - (Abs x b, FV as) -> - mapM (\c -> comp (ext x c g) b) as >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (Abs x b,_) -> comp (ext x a' g) b - (QC _ _,_) -> returnC $ App f' a' - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e - (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e - - _ -> do - (t',b) <- appPredefined (App f' a') - if b then return t' else comp g t' - - P t l -> do - t' <- comp g t - case t' of - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants - R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ - lookup l $ reverse r - - ExtR a (R b) -> - case comp g (P (R b) l) of - Ok v -> return v - _ -> comp g (P a l) - ---- { - --- this is incorrect, since b can contain the proper value - ExtR (R a) b -> -- NOT POSSIBLE both a and b records! - case comp g (P (R a) l) of - Ok v -> return v - _ -> comp g (P b l) ---- - } --- - - - S (T i cs) e -> prawitz g i (flip P l) cs e - S (V i cs) e -> prawitzV g i (flip P l) cs e - - _ -> returnC $ P t' l - - PI t l i -> comp g $ P t l ----- - - S t@(T ti cc) v -> do - v' <- comp g v - case v' of - FV vs -> do - ts' <- mapM (comp g . S t) vs - return $ variants ts' - _ -> case ti of -{- - TComp _ -> do - case term2patt v' of - Ok p' -> case lookup p' cc of - Just u -> comp g u - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - _ -> do - t' <- comp g t - return $ S t' v' --} - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - - - S t v -> do - - t' <- case t of ----- why not? ResFin.Agr "has no values" ----- T (TComp _) _ -> return t ----- V _ _ -> return t - _ -> comp g t - - v' <- comp g v - - case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case t' of - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - T _ [(PV IW,c)] -> comp g c --- an optimization - T _ [(PT _ (PV IW),c)] -> comp g c - - T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization - T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c - - -- course-of-values table: look up by index, no pattern matching needed - V ptyp ts -> do - vs <- allParamValues gr ptyp - case lookup v' (zip vs [0 .. length vs - 1]) of - Just i -> comp g $ ts !! i ------ _ -> prtBad "selection" $ S t' v' -- debug - _ -> return $ S t' v' -- if v' is not canonical - - T (TComp _) cs -> do - case term2patt v' of - Ok p' -> case lookup p' cs of - Just u -> comp g u - _ -> return $ S t' v' -- if v' is not canonical - _ -> return $ S t' v' - - T _ cc -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t - _ -> return $ S t' v' -- if v' is not canonical - - - S (T i cs) e -> prawitz g i (flip S v') cs e - S (V i cs) e -> prawitzV g i (flip S v') cs e - _ -> returnC $ S t' v' - - -- normalize away empty tokens - K "" -> return Empty - - -- glue if you can - Glue x0 y0 -> do - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (FV ks,_) -> do - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e - (s, S (T i cs) e) -> prawitz g i (Glue s) cs e - (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e - (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e - (_,Empty) -> return x - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) - (_, Alts (d,vs)) -> do ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) - (Alts _, ka) -> checks [do - y' <- strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (C u v,_) -> comp g $ C u (Glue v y) - - _ -> do - mapM_ checkNoArgVars [x,y] - r <- composOp (comp g) t - returnC r - - Alts _ -> do - r <- composOp (comp g) t - returnC r - - -- remove empty - C a b -> do - a' <- comp g a - b' <- comp g b - case (a',b') of - (Alts _, K a) -> checks [do - as <- strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] - , - return $ C a' b' - ] - (Empty,_) -> returnC b' - (_,Empty) -> returnC a' - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants - - -- merge record extensions if you can - ExtR r s -> do - r' <- comp g r - s' <- comp g s - case (r',s') of - (R rs, R ss) -> plusRecord r' s' - (RecType rs, RecType ss) -> plusRecType r' s' - _ -> return $ ExtR r' s' - - -- case-expand tables - -- if already expanded, don't expand again - T i@(TComp ty) cs -> do - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapPairsM (comp g) cs ----- return $ V ty (map snd cs') - return $ T i cs' - - T i cs -> do - pty0 <- errIn (prt t) $ getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs -> do - - cs' <- mapM (compBranchOpt g) cs ---- why is this needed?? - sts <- mapM (matchPattern cs') vs - ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts - ps <- mapM term2patt vs - let ps' = ps --- PT ptyp (head ps) : tail ps ----- return $ V ptyp ts -- to save space ---- why doesn't this work?? - return $ T (TComp ptyp) (zip ps' ts) - _ -> do - cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - - -- otherwise go ahead - _ -> composOp (comp g) t >>= returnC - - where - - look p c - | rec = lookupOperDef gr p c >>= comp [] - | otherwise = lookupOperDef gr p c - -{- - look p c = case lookupResDefKind gr p c of - Ok (t,_) | noExpand p || rec -> comp [] t - Ok (t,_) -> return t - Bad s -> raise s - - noExpand p = errVal False $ do - mo <- lookupModMod gr p - return $ case getOptVal (iOpts (flags mo)) useOptimizer of - Just "noexpand" -> True - _ -> False --} - - ext x a g = (x,a):g - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - ts -> FV ts - - isCan v = case v of - Con _ -> True - QC _ _ -> True - App f a -> isCan f && isCan a - R rs -> all (isCan . snd . snd) rs - _ -> False - - compBranch g (p,v) = do - let g' = contP p ++ g - v' <- comp g' v - return (p,v') - - compBranchOpt g c@(p,v) = case contP p of - [] -> return c - _ -> err (const (return c)) return $ compBranch g c - - contP p = case p of - PV x -> [(x,Vr x)] - PC _ ps -> concatMap contP ps - PP _ _ ps -> concatMap contP ps - PT _ p -> contP p - PR rs -> concatMap (contP . snd) rs - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - prawitzV g i f cs e = do - cs' <- mapM (comp g) [(f v) | v <- cs] - return $ S (V i cs') e - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Err Term -checkNoArgVars t = case t of - Vr (IA _) -> Bad $ glueErrorMsg $ prt t - Vr (IAV _) -> Bad $ glueErrorMsg $ prt t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." diff --git a/src-3.0/GF/Devel/Grammar/Construct.hs b/src-3.0/GF/Devel/Grammar/Construct.hs deleted file mode 100644 index 5b4215843..000000000 --- a/src-3.0/GF/Devel/Grammar/Construct.hs +++ /dev/null @@ -1,221 +0,0 @@ -module GF.Devel.Grammar.Construct where - -import GF.Devel.Grammar.Grammar -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map -import Debug.Trace (trace) - ------------------- --- abstractions on Grammar, constructing objects ------------------- - --- abstractions on GF - -emptyGF :: GF -emptyGF = GF Nothing [] empty empty - -type SourceModule = (Ident,Module) - -listModules :: GF -> [SourceModule] -listModules = assocs.gfmodules - -addModule :: Ident -> Module -> GF -> GF -addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} - -gfModules :: [(Ident,Module)] -> GF -gfModules ms = emptyGF {gfmodules = fromList ms} - --- abstractions on Module - -emptyModule :: Module -emptyModule = Module MTGrammar True [] [] [] [] empty empty - -isCompleteModule :: Module -> Bool -isCompleteModule = miscomplete - -isInterface :: Module -> Bool -isInterface m = case mtype m of - MTInterface -> True - MTAbstract -> True - _ -> False - -interfaceName :: Module -> Maybe Ident -interfaceName mo = case mtype mo of - MTInstance i -> return i - MTConcrete i -> return i - _ -> Nothing - -listJudgements :: Module -> [(Ident,Judgement)] -listJudgements = assocs . mjments - -isInherited :: MInclude -> Ident -> Bool -isInherited mi i = case mi of - MIExcept is -> notElem i is - MIOnly is -> elem i is - _ -> True - --- abstractions on Judgement - -isConstructor :: Judgement -> Bool -isConstructor j = jdef j == EData - -isLink :: Judgement -> Bool -isLink j = jform j == JLink - --- constructing judgements from parse tree - -emptyJudgement :: JudgementForm -> Judgement -emptyJudgement form = Judgement form meta meta meta (identC "#") 0 where - meta = Meta 0 - -addJType :: Type -> Judgement -> Judgement -addJType tr ju = ju {jtype = tr} - -addJDef :: Term -> Judgement -> Judgement -addJDef tr ju = ju {jdef = tr} - -addJPrintname :: Term -> Judgement -> Judgement -addJPrintname tr ju = ju {jprintname = tr} - -linkInherited :: Bool -> Ident -> Judgement -linkInherited can mo = (emptyJudgement JLink){ - jlink = mo, - jdef = if can then EData else Meta 0 - } - -absCat :: Context -> Judgement -absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) - -absFun :: Type -> Judgement -absFun ty = addJType ty (emptyJudgement JFun) - -cncCat :: Type -> Judgement -cncCat ty = addJType ty (emptyJudgement JLincat) - -cncFun :: Term -> Judgement -cncFun tr = addJDef tr (emptyJudgement JLin) - -resOperType :: Type -> Judgement -resOperType ty = addJType ty (emptyJudgement JOper) - -resOperDef :: Term -> Judgement -resOperDef tr = addJDef tr (emptyJudgement JOper) - -resOper :: Type -> Term -> Judgement -resOper ty tr = addJDef tr (resOperType ty) - -resOverload :: [(Type,Term)] -> Judgement -resOverload tts = resOperDef (Overload tts) - --- param p = ci gi is encoded as p : ((ci : gi) -> p) -> Type --- we use EData instead of p to make circularity check easier -resParam :: Ident -> [(Ident,Context)] -> Judgement -resParam p cos = addJDef (EParam (Con p) cos) (addJType typePType (emptyJudgement JParam)) - --- to enable constructor type lookup: --- create an oper for each constructor p = c g, as c : g -> p = EData -paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)] -paramConstructors p cs = [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs] - --- unifying contents of judgements - ----- used in SourceToGF; make error-free and informative -unifyJudgements j k = case unifyJudgement j k of - Ok l -> l - Bad s -> error s - -unifyJudgement :: Judgement -> Judgement -> Err Judgement -unifyJudgement old new = do - testErr (jform old == jform new) "different judment forms" - [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] - return $ old{jtype = jty, jdef = jde, jprintname = jpri} - where - unifyField field = unifyTerm (field old) (field new) - unifyTerm oterm nterm = case (oterm,nterm) of - (Meta _,t) -> return t - (t,Meta _) -> return t - _ -> do - if (nterm /= oterm) - then (trace (unwords ["illegal update of",show oterm,"to",show nterm]) - (return ())) - else return () ---- to recover from spurious qualification conflicts ----- testErr (nterm == oterm) ----- (unwords ["illegal update of",prt oterm,"to",prt nterm]) - return nterm - -updateJudgement :: Ident -> Ident -> Judgement -> GF -> Err GF -updateJudgement m c ju gf = do - mo <- maybe (Bad (show m)) return $ Data.Map.lookup m $ gfmodules gf - let mo' = mo {mjments = insert c ju (mjments mo)} - return $ gf {gfmodules = insert m mo' (gfmodules gf)} - --- abstractions on Term - -type Cat = QIdent -type Fun = QIdent -type QIdent = (Ident,Ident) - --- | branches à la Alfa -newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) -type Con = Ident --- - -varLabel :: Int -> Label -varLabel = LVar - -wildPatt :: Patt -wildPatt = PW - -type Trm = Term - -mkProd :: Context -> Type -> Type -mkProd = flip (foldr (uncurry Prod)) - --- type constants - -typeType :: Type -typeType = Sort "Type" - -typePType :: Type -typePType = Sort "PType" - -typeStr :: Type -typeStr = Sort "Str" - -typeTok :: Type ---- deprecated -typeTok = Sort "Tok" - -cPredef :: Ident -cPredef = identC "Predef" - -cPredefAbs :: Ident -cPredefAbs = identC "PredefAbs" - -typeString, typeFloat, typeInt :: Term -typeInts :: Integer -> Term - -typeString = constPredefRes "String" -typeInt = constPredefRes "Int" -typeFloat = constPredefRes "Float" -typeInts i = App (constPredefRes "Ints") (EInt i) - -isTypeInts :: Term -> Bool -isTypeInts ty = case ty of - App c _ -> c == constPredefRes "Ints" - _ -> False - -cnPredef = constPredefRes - -constPredefRes :: String -> Term -constPredefRes s = Q (IC "Predef") (identC s) - -isPredefConstant :: Term -> Bool -isPredefConstant t = case t of - Q (IC "Predef") _ -> True - Q (IC "PredefAbs") _ -> True - _ -> False - - diff --git a/src-3.0/GF/Devel/Grammar/GFtoSource.hs b/src-3.0/GF/Devel/Grammar/GFtoSource.hs deleted file mode 100644 index 292f5b826..000000000 --- a/src-3.0/GF/Devel/Grammar/GFtoSource.hs +++ /dev/null @@ -1,223 +0,0 @@ -module GF.Devel.Grammar.GFtoSource ( - trGrammar, - trModule, - trAnyDef, - trLabel, - trt, - tri, - trp - ) where - - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros (contextOfType) -import qualified GF.Devel.Compile.AbsGF as P -import GF.Infra.Ident - -import GF.Data.Operations - -import qualified Data.Map as Map - --- From internal source syntax to BNFC-generated (used for printing). --- | AR 13\/5\/2003 --- --- translate internal to parsable and printable source - -trGrammar :: GF -> P.Grammar -trGrammar = P.Gr . map trModule . listModules -- no includes - -trModule :: (Ident,Module) -> P.ModDef -trModule (i,mo) = P.MModule compl typ body where - compl = case isCompleteModule mo of - False -> P.CMIncompl - _ -> P.CMCompl - i' = tri i - typ = case mtype mo of - MTGrammar -> P.MGrammar i' - MTAbstract -> P.MAbstract i' - MTConcrete a -> P.MConcrete i' (tri a) - MTInterface -> P.MInterface i' - MTInstance a -> P.MInstance i' (tri a) - body = P.MBody - (trExtends (mextends mo)) - (mkOpens (map trOpen (mopens mo))) - (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++ - map trFlag (Map.assocs (mflags mo))) - -trExtends :: [(Ident,MInclude)] -> P.Extend -trExtends [] = P.NoExt -trExtends es = (P.Ext $ map tre es) where - tre (i,c) = case c of - MIAll -> P.IAll (tri i) - MIOnly is -> P.ISome (tri i) (map tri is) - MIExcept is -> P.IMinus (tri i) (map tri is) - -trOpen :: (Ident,Ident) -> P.Open -trOpen (i,j) = P.OQual (tri i) (tri j) - -mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds - -trAnyDef :: (Ident,Judgement) -> [P.TopDef] -trAnyDef (i,ju) = let - i' = mkName i - i0 = tri i - in case jform ju of - JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]] - JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]] - ---- ++ case pt of - ---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] - ---- _ -> [] - ---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]] - JParam -> [P.DefPar [ - P.ParDefDir i0 [ - P.ParConstr (tri c) (map trDecl co) | let EParam _ cos = jdef ju, (c,co) <- cos] - ]] - JOper -> case jdef ju of - Overload tysts -> - [P.DefOper [P.DDef [i'] ( - P.EApp (P.EPIdent $ ppIdent "overload") - (P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]] - tr -> [P.DefOper [trDef i (jtype ju) tr]] - JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]] - ---- CncCat pty ptr ppr -> - ---- [P.DefLindef [trDef i' pty ptr]] - ---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] - JLin -> - [P.DefLin [trDef i (Meta 0) (jdef ju)]] - ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] - JLink -> [] - -trDef :: Ident -> Type -> Term -> P.Def -trDef i pty ptr = case (pty,ptr) of - (Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) --- - (_, Meta _) -> P.DDecl [mkName i] (trPerh pty) - (Meta _, _) -> P.DDef [mkName i] (trPerh ptr) - (_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr) - -trPerh p = case p of - Meta _ -> P.EMeta - _ -> trt p - -trFlag :: (Ident,String) -> P.TopDef -trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)] - -trt :: Term -> P.Exp -trt trm = case trm of - Vr s -> P.EPIdent $ tri s ----- Cn s -> P.ECons $ tri s - Con s -> P.EConstr $ tri s - Sort s -> P.ESort $ case s of - "Type" -> P.Sort_Type - "PType" -> P.Sort_PType - "Tok" -> P.Sort_Tok - "Str" -> P.Sort_Str - "Strs" -> P.Sort_Strs - _ -> error $ "not yet sort " +++ show trm ---- - - App c a -> P.EApp (trt c) (trt a) - Abs x b -> P.EAbstr [trb x] (trt b) - Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts] - Meta m -> P.EMeta - Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b) - Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b) - - Example t s -> P.EExample (trt t) s - R [] -> P.ETuple [] --- to get correct parsing when read back - R r -> P.ERecord $ map trAssign r - RecType r -> P.ERecord $ map trLabelling r - ExtR x y -> P.EExtend (trt x) (trt y) - P t l -> P.EProj (trt t) (trLabel l) - PI t l _ -> P.EProj (trt t) (trLabel l) - Q t l -> P.EQCons (tri t) (tri l) - QC t l -> P.EQConstr (tri t) (tri l) - T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc) - T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc) - T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc) - T _ cc -> P.ETable (map trCase cc) - V ty cc -> P.EVTable (trt ty) (map trt cc) - - Typed tr ty -> P.ETyped (trt tr) (trt ty) - Table x v -> P.ETType (trt x) (trt v) - S f x -> P.ESelect (trt f) (trt x) - Let (x,(ma,b)) t -> - P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t) - where - b' = trt b - x' = [tri x] - Empty -> P.EEmpty - K [] -> P.EEmpty - K a -> P.EString a - C a b -> P.EConcat (trt a) (trt b) - - EInt i -> P.EInt i - EFloat i -> P.EFloat i - - EPatt p -> P.EPatt (trp p) - EPattType t -> P.EPattType (trt t) - - Glue a b -> P.EGlue (trt a) (trt b) - Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt] - FV ts -> P.EVariants $ map trt ts - EData -> P.EData - EParam t _ -> trt t - - _ -> error $ "not yet" +++ show trm ---- - -trp :: Patt -> P.Patt -trp p = case p of - PChar -> P.PChar - PChars s -> P.PChars s - PM m c -> P.PM (tri m) (tri c) - PW -> P.PW - PV s | isWildIdent s -> P.PW - PV s -> P.PV $ tri s - PC c [] -> P.PCon $ tri c - PC c a -> P.PC (tri c) (map trp a) - PP p c [] -> P.PQ (tri p) (tri c) - PP p c a -> P.PQC (tri p) (tri c) (map trp a) - PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r] - PString s -> P.PStr s - PInt i -> P.PInt i - PFloat i -> P.PFloat i - PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t) - - PAs x p -> P.PAs (tri x) (trp p) - - PAlt p q -> P.PDisj (trp p) (trp q) - PSeq p q -> P.PSeq (trp p) (trp q) - PRep p -> P.PRep (trp p) - PNeg p -> P.PNeg (trp p) - - -trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty - where - t' = trt t - x = [trLabelIdent lab] - -trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty) - -trCase (patt, trm) = P.Case (trp patt) (trt trm) -trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm) - -trDecl (x,ty) = P.DDDec [trb x] (trt ty) - -tri :: Ident -> P.PIdent -tri i = ppIdent (prIdent i) - -ppIdent i = P.PIdent ((0,0),i) - -trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i) - -trLabel :: Label -> P.Label -trLabel i = case i of - LIdent s -> P.LPIdent $ ppIdent s - LVar i -> P.LVar $ toInteger i - -trLabelIdent i = ppIdent $ case i of - LIdent s -> s - LVar i -> "v" ++ show i --- should not happen - -mkName :: Ident -> P.Name -mkName = P.PIdentName . tri - diff --git a/src-3.0/GF/Devel/Grammar/Grammar.hs b/src-3.0/GF/Devel/Grammar/Grammar.hs deleted file mode 100644 index df5a3907e..000000000 --- a/src-3.0/GF/Devel/Grammar/Grammar.hs +++ /dev/null @@ -1,172 +0,0 @@ -module GF.Devel.Grammar.Grammar where - -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.Map - - ------------------- --- definitions -- ------------------- - -data GF = GF { - gfabsname :: Maybe Ident , - gfcncnames :: [Ident] , - gflags :: Map Ident String , -- value of a global flag - gfmodules :: Map Ident Module - } - -data Module = Module { - mtype :: ModuleType, - miscomplete :: Bool, - minterfaces :: [(Ident,Ident)], -- non-empty for functors - minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for inst'ions - mextends :: [(Ident,MInclude)], - mopens :: [(Ident,Ident)], -- used name, original name - mflags :: Map Ident String, - mjments :: Map Ident Judgement - } - -data ModuleType = - MTAbstract - | MTConcrete Ident - | MTInterface - | MTInstance Ident - | MTGrammar - deriving Eq - -data MInclude = - MIAll - | MIExcept [Ident] - | MIOnly [Ident] - -type Indirection = (Ident,Bool) -- module of origin, whether canonical - -data Judgement = Judgement { - jform :: JudgementForm, -- cat fun lincat lin oper param - jtype :: Type, -- context type lincat - type PType - jdef :: Term, -- lindef def lindef lin def constrs - jprintname :: Term, -- - - prname prname - - - jlink :: Ident, -- if inherited, the supermodule name, else # - jposition :: Int -- line number where def begins - } - deriving Show - -data JudgementForm = - JCat - | JFun - | JLincat - | JLin - | JOper - | JParam - | JLink - deriving (Eq,Show) - -type Type = Term - -data Term = - Vr Ident -- ^ variable - | Con Ident -- ^ constructor - | EData -- ^ to mark in definition that a fun is a constructor - | Sort String -- ^ predefined type - | EInt Integer -- ^ integer literal - | EFloat Double -- ^ floating point literal - | K String -- ^ string literal or token: @\"foo\"@ - | Empty -- ^ the empty string @[]@ - - | App Term Term -- ^ application: @f a@ - | Abs Ident Term -- ^ abstraction: @\x -> b@ - | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) - | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ - | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ - -- only used in internal representation - | Typed Term Term -- ^ type-annotated term --- --- /below this, the constructors are only for concrete syntax/ - | Example Term String -- ^ example-based term: @in M.C "foo" - | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ - | R [Assign] -- ^ record: @{ p = a ; ...}@ - | P Term Label -- ^ projection: @r.p@ - | PI Term Label Int -- ^ index-annotated projection - | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) - - | Table Term Term -- ^ table type: @P => A@ - | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ - | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ - | S Term Term -- ^ selection: @t ! p@ - | Val Type Int -- ^ parameter value number: @T # i# - - | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ - - | Q Ident Ident -- ^ qualified constant from a module - | QC Ident Ident -- ^ qualified constructor from a module - - | C Term Term -- ^ concatenation: @s ++ t@ - | Glue Term Term -- ^ agglutination: @s + t@ - - | EPatt Patt - | EPattType Term - - | EParam Term [(Ident,Context)] -- to encode parameter constructor sets - - | FV [Term] -- ^ free variation: @variants { s ; ... }@ - - | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ - - | Overload [(Type,Term)] - - deriving (Read, Show, Eq, Ord) - -data Patt = - PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ - | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ - | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ - | PString String -- ^ string literal pattern: @\"foo\"@ - | PInt Integer -- ^ integer literal pattern: @12@ - | PFloat Double -- ^ float literal pattern: @1.2@ - | PT Type Patt -- ^ type-annotated pattern - | PAs Ident Patt -- ^ as-pattern: x@p - - -- regular expression patterns - | PNeg Patt -- ^ negated pattern: -p - | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 - | PSeq Patt Patt -- ^ sequence of token parts: p + q - | PRep Patt -- ^ repetition of token part: p* - | PChar -- ^ string of length one: ? - | PChars String -- ^ list of characters: ["aeiou"] - - | PMacro Ident -- #p - | PM Ident Ident -- #m.p - - deriving (Read, Show, Eq, Ord) - --- | to guide computation and type checking of tables -data TInfo = - TRaw -- ^ received from parser; can be anything - | TTyped Type -- ^ type annotated, but can be anything - | TComp Type -- ^ expanded - | TWild Type -- ^ just one wild card pattern, no need to expand - deriving (Read, Show, Eq, Ord) - --- | record label -data Label = - LIdent String - | LVar Int - deriving (Read, Show, Eq, Ord) - -type MetaSymb = Int - -type Decl = (Ident,Term) -- (x:A) (_:A) A -type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) -type Substitution = [(Ident, Term)] -type Equation = ([Patt],Term) - -type Labelling = (Label, Term) -type Assign = (Label, (Maybe Type, Term)) -type Case = (Patt, Term) -type LocalDef = (Ident, (Maybe Type, Term)) - diff --git a/src-3.0/GF/Devel/Grammar/Lookup.hs b/src-3.0/GF/Devel/Grammar/Lookup.hs deleted file mode 100644 index 689996760..000000000 --- a/src-3.0/GF/Devel/Grammar/Lookup.hs +++ /dev/null @@ -1,168 +0,0 @@ -module GF.Devel.Grammar.Lookup where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad (liftM) -import Data.Map -import Data.List (sortBy) ---- - --- look up fields for a constant in a grammar - -lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a -lookupJField field gf m c = do - j <- lookupJudgement gf m c - return $ field j - -lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm -lookupJForm = lookupJField jform - --- the following don't (need to) check that the jment form is adequate - -lookupCatContext :: GF -> Ident -> Ident -> Err Context -lookupCatContext gf m c = do - ty <- lookupJField jtype gf m c - return $ contextOfType ty - -lookupFunType :: GF -> Ident -> Ident -> Err Term -lookupFunType = lookupJField jtype - -lookupLin :: GF -> Ident -> Ident -> Err Term -lookupLin = lookupJField jdef - -lookupLincat :: GF -> Ident -> Ident -> Err Term -lookupLincat = lookupJField jtype - -lookupOperType :: GF -> Ident -> Ident -> Err Term -lookupOperType gr m c = do - ju <- lookupJudgement gr m c - case jform ju of - JParam -> return typePType - _ -> case jtype ju of - Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c) - ty -> return ty ----- can't be just lookupJField jtype - -lookupOperDef :: GF -> Ident -> Ident -> Err Term -lookupOperDef = lookupJField jdef - -lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))] -lookupOverload gr m c = do - tr <- lookupJField jdef gr m c - case tr of - Overload tysts -> return - [(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty] - _ -> Bad $ prt c +++ "is not an overloaded operation" - -lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] -lookupParams gf m c = do - EParam _ ty <- lookupJField jdef gf m c - return ty - -lookupParamConstructor :: GF -> Ident -> Ident -> Err Type -lookupParamConstructor = lookupJField jtype - -lookupParamValues :: GF -> Ident -> Ident -> Err [Term] -lookupParamValues gf m c = do - ps <- lookupParams gf m c - liftM concat $ mapM mkPar ps - where - mkPar (f,co) = do - vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co - return $ lmap (mkApp (QC m f)) vs - -lookupFlags :: GF -> Ident -> [(Ident,String)] -lookupFlags gf m = errVal [] $ do - mo <- lookupModule gf m - return $ toList $ mflags mo - -allParamValues :: GF -> Type -> Err [Term] -allParamValues cnc ptyp = case ptyp of - App (Q (IC "Predef") (IC "Ints")) (EInt n) -> - return [EInt i | i <- [0..n]] - QC p c -> lookupParamValues cnc p c - Q p c -> lookupParamValues cnc p c ---- - - RecType r -> do - let (ls,tys) = unzip $ sortByFst r - tss <- mapM allPV tys - return [R (zipAssign ls ts) | ts <- combinations tss] - _ -> prtBad "cannot find parameter values for" ptyp - where - allPV = allParamValues cnc - -- to normalize records and record types - sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) - -abstractOfConcrete :: GF -> Ident -> Err Ident -abstractOfConcrete gf m = do - mo <- lookupModule gf m - case mtype mo of - MTConcrete a -> return a - MTInstance a -> return a - MTGrammar -> return m - _ -> prtBad "not concrete module" m - -allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)] -allOrigJudgements gf m = errVal [] $ do - mo <- lookupModule gf m - return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink] - -allConcretes :: GF -> Ident -> [Ident] -allConcretes gf m = - [c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m] - --- | select just those modules that a given one depends on, including itself -partOfGrammar :: GF -> (Ident,Module) -> GF -partOfGrammar gr (i,mo) = gr { - gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor] - } - where - mos = toList $ gfmodules gr - modsFor = i : allDepsModule gr mo - -allDepsModule :: GF -> Module -> [Ident] -allDepsModule gr m = iterFix add os0 where - os0 = depPathModule m - add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n] - mods = toList $ gfmodules gr - --- | initial dependency list -depPathModule :: Module -> [Ident] -depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where - fors = case mtype mo of - MTConcrete i -> [i] - MTInstance i -> [i] - _ -> [] - --- infrastructure for lookup - -lookupModule :: GF -> Ident -> Err Module -lookupModule gf m = do - maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf) - --- this finds the immediate definition, which can be a link -lookupIdent :: GF -> Ident -> Ident -> Err Judgement -lookupIdent gf m c = do - mo <- lookupModule gf m - maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo) - --- this follows the link -lookupJudgement :: GF -> Ident -> Ident -> Err Judgement -lookupJudgement gf m c = do - ju <- lookupIdent gf m c - case jform ju of - JLink -> lookupJudgement gf (jlink ju) c - _ -> return ju - -mlookup = Data.Map.lookup - -raiseIdent msg i = raise (msg +++ prIdent i) - -lmap = Prelude.map -llookup = Prelude.lookup - diff --git a/src-3.0/GF/Devel/Grammar/Macros.hs b/src-3.0/GF/Devel/Grammar/Macros.hs deleted file mode 100644 index c1833c62c..000000000 --- a/src-3.0/GF/Devel/Grammar/Macros.hs +++ /dev/null @@ -1,434 +0,0 @@ -module GF.Devel.Grammar.Macros where - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -import GF.Infra.Ident - -import GF.Data.Str -import GF.Data.Operations - -import qualified Data.Map as Map -import Control.Monad (liftM,liftM2) - - --- analyse types and terms - -contextOfType :: Type -> Context -contextOfType ty = co where (co,_,_) = typeForm ty - -typeForm :: Type -> (Context,Term,[Term]) -typeForm t = (co,f,a) where - (co,t2) = prodForm t - (f,a) = appForm t2 - -termForm :: Term -> ([Ident],Term,[Term]) -termForm t = (co,f,a) where - (co,t2) = absForm t - (f,a) = appForm t2 - -prodForm :: Type -> (Context,Term) -prodForm t = case t of - Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val - _ -> ([],t) - -absForm :: Term -> ([Ident],Term) -absForm t = case t of - Abs x val -> (x:co,t2) where (co,t2) = absForm val - _ -> ([],t) - - -appForm :: Term -> (Term,[Term]) -appForm tr = (f,reverse xs) where - (f,xs) = apps tr - apps t = case t of - App f a -> (f2,a:a2) where (f2,a2) = appForm f - _ -> (t,[]) - -valCat :: Type -> Err (Ident,Ident) -valCat typ = case typeForm typ of - (_,Q m c,_) -> return (m,c) - -typeRawSkeleton :: Type -> Err ([(Int,Type)],Type) -typeRawSkeleton typ = do - let (cont,typ) = prodForm typ - args <- mapM (typeRawSkeleton . snd) cont - return ([(length c, v) | (c,v) <- args], typ) - -type MCat = (Ident,Ident) - -sortMCat :: String -> MCat -sortMCat s = (identC "_", identC s) - ---- hack for Editing.actCat in empty state -errorCat :: MCat -errorCat = (identC "?", identC "?") - -getMCat :: Term -> Err MCat -getMCat t = case t of - Q m c -> return (m,c) - QC m c -> return (m,c) - Sort s -> return $ sortMCat s - App f _ -> getMCat f - _ -> error $ "no qualified constant" +++ show t - -typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) -typeSkeleton typ = do - (cont,val) <- typeRawSkeleton typ - cont' <- mapPairsM getMCat cont - val' <- getMCat val - return (cont',val') - --- construct types and terms - -mkFunType :: [Type] -> Type -> Type -mkFunType tt t = mkProd ([(identW, ty) | ty <- tt]) t -- nondep prod - -mkApp :: Term -> [Term] -> Term -mkApp = foldl App - -mkAbs :: [Ident] -> Term -> Term -mkAbs xs t = foldr Abs t xs - -mkCTable :: [Ident] -> Term -> Term -mkCTable ids v = foldr ccase v ids where - ccase x t = T TRaw [(PV x,t)] - -appCons :: Ident -> [Term] -> Term -appCons = mkApp . Con - -appc :: String -> [Term] -> Term -appc = appCons . identC - -tuple2record :: [Term] -> [Assign] -tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts] - -tuple2recordType :: [Term] -> [Labelling] -tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] - -tuple2recordPatt :: [Patt] -> [(Label,Patt)] -tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] - -tupleLabel :: Int -> Label -tupleLabel i = LIdent $ "p" ++ show i - -assign :: Label -> Term -> Assign -assign l t = (l,(Nothing,t)) - -assignT :: Label -> Type -> Term -> Assign -assignT l a t = (l,(Just a,t)) - -unzipR :: [Assign] -> ([Label],[Term]) -unzipR r = (ls, map snd ts) where (ls,ts) = unzip r - -mkDecl :: Term -> Decl -mkDecl typ = (identW, typ) - -mkLet :: [LocalDef] -> Term -> Term -mkLet defs t = foldr Let t defs - -mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type -mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs] - -mkRecType :: (Int -> Label) -> [Type] -> Type -mkRecType = mkRecTypeN 0 - -plusRecType :: Type -> Type -> Err Type -plusRecType t1 t2 = case (t1, t2) of - (RecType r1, RecType r2) -> case - filter (`elem` (map fst r1)) (map fst r2) of - [] -> return (RecType (r1 ++ r2)) - ls -> Bad $ "clashing labels" +++ unwords (map show ls) - _ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show t2) - -plusRecord :: Term -> Term -> Err Term -plusRecord t1 t2 = - case (t1,t2) of - (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields - (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) - (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV - (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV - _ -> Bad ("cannot add records" +++ show t1 +++ "and" +++ show t2) - -zipAssign :: [Label] -> [Term] -> [Assign] -zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] - - -defLinType :: Type -defLinType = RecType [(LIdent "s", typeStr)] - -meta0 :: Term -meta0 = Meta 0 - -ident2label :: Ident -> Label -ident2label c = LIdent (prIdent c) - -label2ident :: Label -> Ident -label2ident (LIdent c) = identC c - -----label2ident :: Label -> Ident -----label2ident = identC . prLabel - --- to apply a term operation to every term in a judgement, module, grammar - -termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF -termOpGF f = moduleOpGF (termOpModule f) - -moduleOpGF :: Monad m => (Module -> m Module) -> GF -> m GF -moduleOpGF f g = do - ms <- mapMapM f (gfmodules g) - return g {gfmodules = ms} - -termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module -termOpModule f = judgementOpModule fj where - fj = termOpJudgement f - -judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module -judgementOpModule f m = do - mjs <- mapMapM f (mjments m) - return m {mjments = mjs} - -entryOpModule :: Monad m => - (Ident -> Judgement -> m Judgement) -> Module -> m Module -entryOpModule f m = do - mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m - return $ m {mjments = mjs} - where - mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j)) - -termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement -termOpJudgement f j = do - jtyp <- f (jtype j) - jde <- f (jdef j) - jpri <- f (jprintname j) - return $ j { - jtype = jtyp, - jdef = jde, - jprintname = jpri - } - --- | to define compositional term functions -composSafeOp :: (Term -> Term) -> Term -> Term -composSafeOp op trm = case composOp (mkMonadic op) trm of - Ok t -> t - _ -> error "the operation is safe isn't it ?" - where - mkMonadic f = return . f - --- | to define compositional monadic term functions -composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp co trm = case trm of - App c a -> - do c' <- co c - a' <- co a - return (App c' a') - Abs x b -> - do b' <- co b - return (Abs x b') - Prod x a b -> - do a' <- co a - b' <- co b - return (Prod x a' b') - S c a -> - do c' <- co c - a' <- co a - return (S c' a') - Table a c -> - do a' <- co a - c' <- co c - return (Table a' c') - R r -> - do r' <- mapAssignM co r - return (R r') - RecType r -> - do r' <- mapPairListM (co . snd) r - return (RecType r') - P t i -> - do t' <- co t - return (P t' i) - PI t i j -> - do t' <- co t - return (PI t' i j) - ExtR a c -> - do a' <- co a - c' <- co c - return (ExtR a' c') - T i cc -> - do cc' <- mapPairListM (co . snd) cc - i' <- changeTableType co i - return (T i' cc') - Eqs cc -> - do cc' <- mapPairListM (co . snd) cc - return (Eqs cc') - EParam ty cos -> - do ty' <- co ty - cos' <- mapPairListM (mapPairListM (co . snd) . snd) cos - return (EParam ty' cos') - V ty vs -> - do ty' <- co ty - vs' <- mapM co vs - return (V ty' vs') - Let (x,(mt,a)) b -> - do a' <- co a - mt' <- case mt of - Just t -> co t >>= (return . Just) - _ -> return mt - b' <- co b - return (Let (x,(mt',a')) b') - C s1 s2 -> - do v1 <- co s1 - v2 <- co s2 - return (C v1 v2) - Glue s1 s2 -> - do v1 <- co s1 - v2 <- co s2 - return (Glue v1 v2) - Alts (t,aa) -> - do t' <- co t - aa' <- mapM (pairM co) aa - return (Alts (t',aa')) - FV ts -> mapM co ts >>= return . FV - Overload tts -> do - tts' <- mapM (pairM co) tts - return $ Overload tts' - - EPattType ty -> - do ty' <- co ty - return (EPattType ty') - - _ -> return trm -- covers K, Vr, Cn, Sort - - ----- should redefine using composOp -collectOp :: (Term -> [a]) -> Term -> [a] -collectOp co trm = case trm of - App c a -> co c ++ co a - Abs _ b -> co b - Prod _ a b -> co a ++ co b - S c a -> co c ++ co a - Table a c -> co a ++ co c - ExtR a c -> co a ++ co c - R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r - RecType r -> concatMap (co . snd) r - P t i -> co t - T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot - V _ cc -> concatMap co cc --- nor from type annot - Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b - C s1 s2 -> co s1 ++ co s2 - Glue s1 s2 -> co s1 ++ co s2 - Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y) - FV ts -> concatMap co ts - _ -> [] -- covers K, Vr, Cn, Sort, Ready - ---- just aux to composOp? - -mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] -mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv)) - where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v) - -changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo -changeTableType co i = case i of - TTyped ty -> co ty >>= return . TTyped - TComp ty -> co ty >>= return . TComp - TWild ty -> co ty >>= return . TWild - _ -> return i - - -patt2term :: Patt -> Term -patt2term pt = case pt of - PV x -> Vr x - PW -> Vr identW --- not parsable, should not occur - PC c pp -> mkApp (Con c) (map patt2term pp) - PP p c pp -> mkApp (QC p c) (map patt2term pp) - PR r -> R [assign l (patt2term p) | (l,p) <- r] - PT _ p -> patt2term p - PInt i -> EInt i - PFloat i -> EFloat i - PString s -> K s - - PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding - PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding - PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding - PRep a -> appc "*" [(patt2term a)] --- an encoding - PNeg a -> appc "-" [(patt2term a)] --- an encoding - - -term2patt :: Term -> Err Patt -term2patt trm = case Ok (termForm trm) of - Ok ([], Vr x, []) -> return (PV x) - Ok ([], QC p c, aa) -> do - aa' <- mapM term2patt aa - return (PP p c aa') - Ok ([], R r, []) -> do - let (ll,aa) = unzipR r - aa' <- mapM term2patt aa - return (PR (zip ll aa')) - Ok ([],EInt i,[]) -> return $ PInt i - Ok ([],EFloat i,[]) -> return $ PFloat i - Ok ([],K s, []) -> return $ PString s - ---- encodings due to excessive use of term-patt convs. AR 7/1/2005 - Ok ([], Con (IC "@"), [Vr a,b]) -> do - b' <- term2patt b - return (PAs a b') - Ok ([], Con (IC "-"), [a]) -> do - a' <- term2patt a - return (PNeg a') - Ok ([], Con (IC "*"), [a]) -> do - a' <- term2patt a - return (PRep a') - Ok ([], Con (IC "+"), [a,b]) -> do - a' <- term2patt a - b' <- term2patt b - return (PSeq a' b') - Ok ([], Con (IC "|"), [a,b]) -> do - a' <- term2patt a - b' <- term2patt b - return (PAlt a' b') - - Ok ([], Con c, aa) -> do - aa' <- mapM term2patt aa - return (PC c aa') - - _ -> Bad $ "no pattern corresponds to term" +++ show trm - -getTableType :: TInfo -> Err Type -getTableType i = case i of - TTyped ty -> return ty - TComp ty -> return ty - TWild ty -> return ty - _ -> Bad "the table is untyped" - --- | to get a string from a term that represents a sequence of terminals -strsFromTerm :: Term -> Err [Str] -strsFromTerm t = case t of - K s -> return [str s] - Empty -> return [str []] - C s t -> do - s' <- strsFromTerm s - t' <- strsFromTerm t - return [plusStr x y | x <- s', y <- t'] - Glue s t -> do - s' <- strsFromTerm s - t' <- strsFromTerm t - return [glueStr x y | x <- s', y <- t'] - Alts (d,vs) -> do - d0 <- strsFromTerm d - v0 <- mapM (strsFromTerm . fst) vs - c0 <- mapM (strsFromTerm . snd) vs - let vs' = zip v0 c0 - return [strTok (str2strings def) vars | - def <- d0, - vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | - vv <- combinations v0] - ] - FV ts -> mapM strsFromTerm ts >>= return . concat - _ -> Bad $ "cannot get Str from term" +++ show t - - - ----- given in lib? - -mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v) -mapMapM f = - liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs - diff --git a/src-3.0/GF/Devel/Grammar/PatternMatch.hs b/src-3.0/GF/Devel/Grammar/PatternMatch.hs deleted file mode 100644 index ec64d7802..000000000 --- a/src-3.0/GF/Devel/Grammar/PatternMatch.hs +++ /dev/null @@ -1,146 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PatternMatch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/12 12:38:29 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.PatternMatch (matchPattern, - testOvershadow, - findMatch - ) where - - -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident - -import GF.Data.Operations - -import Data.List -import Control.Monad - - -matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) -matchPattern pts term = - if not (isInConstantForm term) - then prtBad "variables occur in" term - else - errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $ - findMatch [([p],t) | (p,t) <- pts] [term] - -testOvershadow :: [Patt] -> [Term] -> Err [Patt] -testOvershadow pts vs = do - let numpts = zip pts [0..] - let cases = [(p,EInt i) | (p,i) <- numpts] - ts <- mapM (liftM fst . matchPattern cases) vs - return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] - -findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) -findMatch cases terms = case cases of - [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) - (patts,_):_ | length patts /= length terms -> - Bad ("wrong number of args for patterns :" +++ - unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (val, concat substs) - _ -> findMatch cc terms - -tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do - let t' = termForm t - trym p t' - where - isInConstantFormt = True -- tested already - trym p t' = - case (p,t') of - (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] - (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard - (PV x, _) | isInConstantFormt -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PC p pp, ([], Con f, tt)) | - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PP q p pp, ([], QC r f, tt)) | - -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - ---- hack for AppPredef bug - (PP q p pp, ([], Q r f, tt)) | - -- q `eqStrIdent` r && --- - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PR r, ([],R r',[])) | - all (`elem` map fst r') (map fst r) -> - do matches <- mapM tryMatch - [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] - return (concat matches) - (PT _ p',_) -> trym p' t' - --- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do - - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - - (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t'] - - (PNeg p',_) -> case tryMatch (p',t) of - Bad _ -> return [] - _ -> prtBad "no match with negative pattern" p - - (PSeq p1 p2, ([],K s, [])) -> do - let cuts = [splitAt n s | n <- [0 .. length s]] - matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts] - return (concat matches) - - (PRep p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq p1)) (PString "") - [1..n]) t' | n <- [0 .. length s] - ] >> - return [] - - (PChar, ([],K [_], [])) -> return [] - (PChars cs, ([],K [c], [])) | elem c cs -> return [] - - _ -> prtBad "no match in case expr for" t - -eqStrIdent = (==) ---- - -isInConstantForm :: Term -> Bool -isInConstantForm trm = case trm of - Con _ -> True - Q _ _ -> True - QC _ _ -> True - Abs _ _ -> True - App c a -> isInConstantForm c && isInConstantForm a - R r -> all (isInConstantForm . snd . snd) r - K _ -> True - Empty -> True - EInt _ -> True - _ -> False ---- isInArgVarForm trm - -varsOfPatt :: Patt -> [Ident] -varsOfPatt p = case p of - PV x -> [x | not (isWildIdent x)] - PC _ ps -> concat $ map varsOfPatt ps - PP _ _ ps -> concat $ map varsOfPatt ps - PR r -> concat $ map (varsOfPatt . snd) r - PT _ q -> varsOfPatt q - _ -> [] - diff --git a/src-3.0/GF/Devel/Grammar/PrGF.hs b/src-3.0/GF/Devel/Grammar/PrGF.hs deleted file mode 100644 index cd55e9d67..000000000 --- a/src-3.0/GF/Devel/Grammar/PrGF.hs +++ /dev/null @@ -1,246 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/04 11:45:38 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003 - 4/12/2007 --- --- printing and prettyprinting class for source grammar --- --- 8\/1\/2004: --- Usually followed principle: 'prt_' for displaying in the editor, 'prt' --- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree', --- only the former is ever needed. ------------------------------------------------------------------------------ - -module GF.Devel.Grammar.PrGF where - -import qualified GF.Devel.Compile.PrintGF as P -import GF.Devel.Grammar.GFtoSource -import GF.Devel.Grammar.Grammar -import GF.Devel.Grammar.Construct -----import GF.Grammar.Values - -----import GF.Infra.Option -import GF.Infra.Ident -import GF.Infra.CompactPrint -----import GF.Data.Str - -import GF.Data.Operations -----import GF.Data.Zipper - -import Data.List (intersperse) - -class Print a where - prt :: a -> String - -- | printing with parentheses, if needed - prt2 :: a -> String - -- | pretty printing - prpr :: a -> [String] - -- | printing without ident qualifications - prt_ :: a -> String - prt2 = prt - prt_ = prt - prpr = return . prt - --- 8/1/2004 ---- Usually followed principle: prt_ for displaying in the editor, prt ---- in writing grammars to a file. For some constructs, e.g. prMarkedTree, ---- only the former is ever needed. - -cprintTree :: P.Print a => a -> String -cprintTree = compactPrint . P.printTree - --- | to show terms etc in error messages -prtBad :: Print a => String -> a -> Err b -prtBad s a = Bad (s +++ prt a) - -prGF :: GF -> String -prGF = cprintTree . trGrammar - -instance Print GF where - prt = cprintTree . trGrammar - -prModule :: SourceModule -> String -prModule = cprintTree . trModule - -instance Print Judgement where - prt j = cprintTree $ trAnyDef (identW, j) ----- prt_ = prExp - -instance Print Term where - prt = cprintTree . trt ----- prt_ = prExp - -instance Print Ident where - prt = cprintTree . tri - -instance Print Patt where - prt = P.printTree . trp - -instance Print Label where - prt = P.printTree . trLabel - -{- -instance Print MetaSymb where - prt (MetaSymb i) = "?" ++ show i - -prParam :: Param -> String -prParam (c,co) = prt c +++ prContext co - -prContext :: Context -> String -prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co] - - --- printing values and trees in editing - -instance Print a => Print (Tr a) where - prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees) - prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t) - --- | we cannot define the method prt_ in this way -prt_Tree :: Tree -> String -prt_Tree = prt_ . tree2exp - -instance Print TrNode where - prt (N (bi,at,vt,(cs,ms),_)) = - prBinds bi ++ - prt at +++ ":" +++ prt vt - +++ prConstraints cs +++ prMetaSubst ms - prt_ (N (bi,at,vt,(cs,ms),_)) = - prBinds bi ++ - prt_ at +++ ":" +++ prt_ vt - +++ prConstraints cs +++ prMetaSubst ms - -prMarkedTree :: Tr (TrNode,Bool) -> [String] -prMarkedTree = prf 1 where - prf ind t@(Tr (node, trees)) = - prNode ind node : concatMap (prf (ind + 2)) trees - prNode ind node = case node of - (n, False) -> indent ind (prt_ n) - (n, _) -> '*' : indent (ind - 1) (prt_ n) - -prTree :: Tree -> [String] -prTree = prMarkedTree . mapTr (\n -> (n,False)) - --- | a pretty-printer for parsable output -tree2string :: Tree -> String -tree2string = unlines . prprTree - -prprTree :: Tree -> [String] -prprTree = prf False where - prf par t@(Tr (node, trees)) = - parIf par (prn node : concat [prf (ifPar t) t | t <- trees]) - prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at - prb [] = "" - prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> " - parIf par (s:ss) = map (indent 2) $ - if par - then ('(':s) : ss ++ [")"] - else s:ss - ifPar (Tr (N ([],_,_,_,_), [])) = False - ifPar _ = True - - --- auxiliaries - -prConstraints :: Constraints -> String -prConstraints = concat . prConstrs - -prMetaSubst :: MetaSubst -> String -prMetaSubst = concat . prMSubst - -prEnv :: Env -> String ----- prEnv [] = prCurly "" ---- for debugging -prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e - -prConstrs :: Constraints -> [String] -prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w)) - -prMSubst :: MetaSubst -> [String] -prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e)) - -prBinds bi = if null bi - then [] - else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> " - where - prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t) - -instance Print Val where - prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging - prt (VApp u v) = prt u +++ prv1 v - prt (VCn mc) = prQIdent_ mc - prt (VClos env e) = case e of - Meta _ -> prt_ e ++ prEnv env - _ -> prt_ e ---- ++ prEnv env ---- for debugging - prt VType = "Type" - -prv1 v = case v of - VApp _ _ -> prParenth $ prt v - VClos _ _ -> prParenth $ prt v - _ -> prt v - -instance Print Atom where - prt (AtC f) = prQIdent f - prt (AtM i) = prt i - prt (AtV i) = prt i - prt (AtL s) = prQuotedString s - prt (AtI i) = show i - prt (AtF i) = show i - prt_ (AtC (_,f)) = prt f - prt_ a = prt a - -prQIdent :: QIdent -> String -prQIdent (m,f) = prt m ++ "." ++ prt f - -prQIdent_ :: QIdent -> String -prQIdent_ (_,f) = prt f - --- | print terms without qualifications -prExp :: Term -> String -prExp e = case e of - App f a -> pr1 f +++ pr2 a - Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b - Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b - Q _ c -> prt c - QC _ c -> prt c - _ -> prt e - where - pr1 e = case e of - Abs _ _ -> prParenth $ prExp e - Prod _ _ _ -> prParenth $ prExp e - _ -> prExp e - pr2 e = case e of - App _ _ -> prParenth $ prExp e - _ -> pr1 e - --- | option @-strip@ strips qualifications -prTermOpt :: Options -> Term -> String -prTermOpt opts = if oElem nostripQualif opts then prt else prExp - --- | to get rid of brackets in the editor -prRefinement :: Term -> String -prRefinement t = case t of - Q m c -> prQIdent (m,c) - QC m c -> prQIdent (m,c) - _ -> prt t - -prOperSignature :: (QIdent,Type) -> String -prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t - --- to look up a constant etc in a search tree - -lookupIdent :: Ident -> BinTree Ident b -> Err b -lookupIdent c t = case lookupTree prt c t of - Ok v -> return v - _ -> prtBad "unknown identifier" c - -lookupIdentInfo :: Module Ident f a -> Ident -> Err a -lookupIdentInfo mo i = lookupIdent i (jments mo) --} diff --git a/src-3.0/GF/Devel/Infra/ReadFiles.hs b/src-3.0/GF/Devel/Infra/ReadFiles.hs deleted file mode 100644 index dd8cbe5a9..000000000 --- a/src-3.0/GF/Devel/Infra/ReadFiles.hs +++ /dev/null @@ -1,348 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReadFiles --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Decide what files to read as function of dependencies and time stamps. --- --- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 --- --- to find all files that have to be read, put them in dependency order, and --- decide which files need recompilation. Name @file.gf@ is returned for them, --- and @file.gfo@ otherwise. ------------------------------------------------------------------------------ - -module GF.Devel.Infra.ReadFiles (-- * Heading 1 - getAllFiles,fixNewlines,ModName,getOptionsFromFile, - -- * Heading 2 - gfoFile,gfFile,isGFO,resModName,isOldFile - ) where - -import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime) - -import GF.Infra.Option -import GF.Data.Operations -import GF.Devel.UseIO - -import System -import Data.Char -import Control.Monad -import Data.List -import System.Directory - -type ModName = String -type ModEnv = [(ModName,ModTime)] - -getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] -getAllFiles opts ps env file = do - - -- read module headers from all files recursively - ds0 <- getImports ps file - let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] - if oElem beVerbose opts - then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) - else return () - -- get a topological sorting of files: returns file names --- deletes paths - ds1 <- ioeErr $ either - return - (\ms -> Bad $ "circular modules" +++ - unwords (map show (head ms))) $ topoTest $ map fst ds - - -- associate each file name with its path --- more optimal: save paths in ds1 - let paths = [(f,p) | ((f,_),p) <- ds] - let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] - if oElem fromSource opts - then return [gfFile (p f) | (p,f) <- pds1] - else do - - - ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 - - let ds4 = needCompile opts (map fst ds0) ds2 - return ds4 - --- to decide whether to read gf or gfo, or if in env; returns full file path - -data CompStatus = - CSComp -- compile: read gf - | CSRead -- read gfo - | CSEnv -- gfo is in env - | CSEnvR -- also gfr is in env - | CSDont -- don't read at all - | CSRes -- read gfr - deriving (Eq,Show) - --- for gfo, we also return ModTime to cope with earlier compilation of libs - -selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> - IO (ModName,(InitPath,(CompStatus,Maybe ModTime))) - -selectFormat opts env (p,f) = do - let pf = p f - let mtenv = lookup f env -- Nothing if f is not in env - let rtenv = lookup (resModName f) env - let fromComp = oElem isCompiled opts -- i -gfo - mtgfc <- getModTime $ gfoFile pf - mtgf <- getModTime $ gfFile pf - let stat = case (rtenv,mtenv,mtgfc,mtgf) of - (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) - (_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc) - (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv) - (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv) - (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> (CSRead,Just tgfc) - (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist - (_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist - _ -> (CSComp,Nothing) - return $ (f, (p,stat)) - -needCompile :: Options -> - [ModuleHeader] -> - [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath] -needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where - - deps = [(snd m,map fst ms) | (m,ms) <- headers] - typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers] - uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m] - stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0 - - allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where - add os = [m | o <- os, Just n <- [lookup o deps],m <- n] - - -- only treat reused, interface, or instantiation if needed - sfiles = sfiles0 ---- map relevant sfiles0 - relevant fp@(f,(p,(st,_))) = - let us = uses f - isUsed = not (null us) - in - if not (isUsed && all noComp us) then - fp else - if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource] - || - (isUsed && all isAux us)) then - (f,(p,(CSDont,Nothing))) else - fp - - isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd - noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst - - -- mark as to be compiled those whose gfo is earlier than a deeper gfo - sfiles1 = map compTimes sfiles - compTimes fp@(f,(p,(_, Just t))) = - if any (> t) [t' | Just fs <- [lookup f deps], - f0 <- fs, - Just (_,(_,Just t')) <- [lookup f0 sfiles]] - then (f,(p,(CSComp, Nothing))) - else fp - compTimes fp = fp - - -- start with the changed files themselves; returns [ModName] - changed = [f | (f,(_,(CSComp,_))) <- sfiles1] - - -- add other files that depend on some changed file; returns [ModName] - iter np = let new = [f | (f,fs) <- deps, - not (elem f np), any (flip elem np) fs] - in if null new then np else (iter (new ++ np)) - - -- for each module in the full list, compile if depends on what needs compile - -- returns [FullPath] - mark cs = [(f,(path,st)) | - (f,(path,(st0,_))) <- sfiles1, - let st = if (elem f cs) then CSComp else st0] - - - -- Also read res if the option "retain" is present - -- Also, if a "with" file has to be compiled, read its mother file from source - - res cs = map mkRes cs where - mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of - t | (not (null [m | (m,(_,CSComp)) <- cs, - Just ms <- [lookup m allDeps], elem f ms]) - || oElem retainOpers opts) - -> if elem t [MTyResource,MTyIncResource] - then (f,(path,CSRes)) else - if t == MTyIncomplete - then (f,(path,CSComp)) else - x - _ -> x - mkRes x = x - - - - -- construct list of paths to read - paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]] - - mkName f p st = mk (p f) where - mk = case st of - CSComp -> gfFile - CSRead -> gfoFile - CSRes -> gfoFile ---- gfr - -isGFO :: FilePath -> Bool -isGFO = (== ".gfn") . takeExtensions - -gfoFile :: FilePath -> FilePath -gfoFile f = addExtension f "gfn" - -gfFile :: FilePath -> FilePath -gfFile f = addExtension f "gf" - -resModName :: ModName -> ModName -resModName = ('#':) - --- to get imports without parsing the whole files - -getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)] -getImports ps = get [] where - get ds file0 = do - let name = dropExtension file0 ---- dropExtension file0 - (p,s) <- tryRead name - let ((typ,mname),imps) = importsOfFile s - let namebody = takeFileName name - ioeErr $ testErr (mname == namebody) $ - "module name" +++ mname +++ "differs from file name" +++ namebody - case imps of - _ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read - [] -> return $ (((typ,name),[]),p):ds - _ -> do - let files = map (gfFile . fst) imps - foldM get ((((typ,name),imps),p):ds) files - tryRead name = do - file <- do - let file_gf = gfFile name - b <- doesFileExistPath ps file_gf -- try gf file first - if b then return file_gf else do - return (gfoFile name) -- gfo next - - readFileIfPath ps $ file - - - --- internal module dep information - -data ModUse = - MUReuse - | MUInstance - | MUComplete - | MUOther - deriving (Eq,Show) - -data ModTyp = - MTyResource - | MTyIncomplete - | MTyIncResource -- interface, incomplete resource - | MTyOther - deriving (Eq,Show) - -type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) - -importsOfFile :: String -> ModuleHeader -importsOfFile = - getModuleHeader . -- analyse into mod header - filter (not . spec) . -- ignore keywords and special symbols - unqual . -- take away qualifiers - unrestr . -- take away union restrictions - takeWhile (not . term) . -- read until curly or semic - lexs . -- analyse into lexical tokens - unComm -- ignore comments before the headed line - where - term = flip elem ["{",";"] - spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"] - unqual ws = case ws of - "(":q:ws' -> unqual ws' - w:ws' -> w:unqual ws' - _ -> ws - unrestr ws = case ws of - "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws' - w:ws' -> w:unrestr ws' - _ -> ws - -getModuleHeader :: [String] -> ModuleHeader -- with, reuse -getModuleHeader ws = case ws of - "incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in - case ty of - MTyResource -> ((MTyIncResource,name),us) - _ -> ((MTyIncomplete,name),us) - "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in - ((MTyIncResource,name),us) - - "resource":name:ws2 -> case ws2 of - "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)]) - m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - ms -> ((MTyResource,name),[(n,MUOther) | n <- ms]) - - "instance":name:m:ws2 -> case ws2 of - "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)]) - n:"with":ms -> - ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms]) - ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms]) - - "concrete":name:a:ws2 -> case span (/= "with") ws2 of - - (es,_:ms) -> ((MTyOther,name), - [(m,MUOther) | m <- es] ++ - [(n,MUComplete) | n <- ms]) - --- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - (ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms]) - - _:name:ws2 -> case ws2 of - "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)]) - ---- m:n:"with":ms -> - ---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms]) - m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - ms -> ((MTyOther,name),[(n,MUOther) | n <- ms]) - _ -> error "the file is empty" - -unComm s = case s of - '-':'-':cs -> unComm $ dropWhile (/='\n') cs - '{':'-':cs -> dpComm cs - c:cs -> c : unComm cs - _ -> s - -dpComm s = case s of - '-':'}':cs -> unComm cs - c:cs -> dpComm cs - _ -> s - -lexs s = x:xs where - (x,y) = head $ lex s - xs = if null y then [] else lexs y - --- | options can be passed to the compiler by comments in @--#@, in the main file -getOptionsFromFile :: FilePath -> IO Options -getOptionsFromFile file = do - s <- readFileIfStrict file - let ls = filter (isPrefixOf "--#") $ lines s - return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls - --- | check if old GF file -isOldFile :: FilePath -> IO Bool -isOldFile f = do - s <- readFileIfStrict f - let s' = unComm s - return $ not (null s') && old (head (words s')) - where - old = flip elem $ words - "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule" - - - --- | old GF tolerated newlines in quotes. No more supported! -fixNewlines :: String -> String -fixNewlines s = case s of - '"':cs -> '"':mk cs - c :cs -> c:fixNewlines cs - _ -> s - where - mk s = case s of - '\\':'"':cs -> '\\':'"': mk cs - '"' :cs -> '"' :fixNewlines cs - '\n' :cs -> '\\':'n': mk cs - c :cs -> c : mk cs - _ -> s - diff --git a/src-3.0/GF/Devel/Options.hs b/src-3.0/GF/Devel/Options.hs deleted file mode 100644 index 9a4087096..000000000 --- a/src-3.0/GF/Devel/Options.hs +++ /dev/null @@ -1,269 +0,0 @@ -module GF.Devel.Options - ( - Err(..), -- FIXME: take from somewhere else - - Options(..), - Mode(..), Phase(..), OutputFormat(..), Optimization(..), - parseOptions, helpMessage - ) where - -import Control.Monad -import Data.Char (toLower) -import Data.List -import Data.Maybe -import System.Console.GetOpt -import System.FilePath - - - - - -usageHeader :: String -usageHeader = unlines - ["Usage: gfc [OPTIONS] [FILE [...]]", - "", - "How each FILE is handled depends on the file name suffix:", - "", - ".gf Normal or old GF source, will be compiled.", - ".gfc Compiled GF source, will be loaded as is.", - ".gfe Example-based GF source, will be converted to .gf and compiled.", - ".ebnf Extended BNF format, will be converted to .gf and compiled.", - ".cf Context-free (BNF) format, will be converted to .gf and compiled.", - "", - "If multiple FILES are given, they must be normal GF source, .gfc or .gfe files.", - "For the other input formats, only one file can be given.", - "", - "Command-line options:"] - - -helpMessage :: String -helpMessage = usageInfo usageHeader optDescr - --- Error monad - -type ErrorMsg = String - -data Err a = Ok a | Errors [ErrorMsg] - deriving (Read, Show, Eq) - -instance Monad Err where - return = Ok - fail e = Errors [e] - Ok a >>= f = f a - Errors s >>= f = Errors s - -errors :: [ErrorMsg] -> Err a -errors = Errors - --- Types - -data Mode = Version | Help | Interactive | Compiler - deriving (Show,Eq,Ord) - -data Phase = Preproc | Convert | Compile | Link - deriving (Show,Eq,Ord) - -data Encoding = UTF_8 | ISO_8859_1 - deriving (Show,Eq,Ord) - -data OutputFormat = FmtGFCC | FmtJS - deriving (Show,Eq,Ord) - -data Optimization = OptStem | OptCSE - deriving (Show,Eq,Ord) - -data Warning = WarnMissingLincat - deriving (Show,Eq,Ord) - -data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypecheck | DumpRefresh | DumpOptimize | DumpCanon - deriving (Show,Eq,Ord) - -data ModuleOptions = ModuleOptions { - optPreprocessors :: [String], - optEncoding :: Encoding, - optOptimizations :: [Optimization], - optLibraryPath :: [FilePath], - optSpeechLanguage :: Maybe String, - optBuildParser :: Bool, - optWarnings :: [Warning], - optDump :: [Dump] - } - deriving (Show) - -data Options = Options { - optMode :: Mode, - optStopAfterPhase :: Phase, - optVerbosity :: Int, - optShowCPUTime :: Bool, - optEmitGFO :: Bool, - optGFODir :: FilePath, - optOutputFormats :: [OutputFormat], - optOutputName :: Maybe String, - optOutputFile :: Maybe FilePath, - optOutputDir :: FilePath, - optForceRecomp :: Bool, - optProb :: Bool, - optStartCategory :: Maybe String, - optModuleOptions :: ModuleOptions - } - deriving (Show) - --- Option parsing - -parseOptions :: [String] -> Err (Options, [FilePath]) -parseOptions args = case errs of - [] -> do o <- foldM (\o f -> f o) defaultOptions opts - return (o, files) - _ -> errors errs - where (opts, files, errs) = getOpt RequireOrder optDescr args - -parseModuleFlags :: Options -> [(String,String)] -> Err ModuleOptions -parseModuleFlags opts flags = foldr setOpt (optModuleOptions opts) moduleOptDescr - where - setOpt (Option _ ss arg _) d - | null values = d - | otherwise = case arg of - NoArg a -> - ReqArg (String -> a) _ -> -OptArg (Maybe String -> a) String -last values - where values = [v | (k,v) <- flags, k `elem` ss ] - --- Default options - -defaultModuleOptions :: ModuleOptions -defaultModuleOptions = ModuleOptions { - optPreprocessors = [], - optEncoding = ISO_8859_1, - optOptimizations = [OptStem,OptCSE], - optLibraryPath = [], - optSpeechLanguage = Nothing, - optBuildParser = True, - optWarnings = [], - optDump = [] - } - -defaultOptions :: Options -defaultOptions = Options { - optMode = Interactive, - optStopAfterPhase = Link, - optVerbosity = 1, - optShowCPUTime = False, - optEmitGFO = True, - optGFODir = ".", - optOutputFormats = [FmtGFCC], - optOutputName = Nothing, - optOutputFile = Nothing, - optOutputDir = ".", - optForceRecomp = False, - optProb = False, - optStartCategory = Nothing, - optModuleOptions = defaultModuleOptions - } - --- Option descriptions - -moduleOptDescr :: [OptDescr (ModuleOptions -> Err ModuleOptions)] -moduleOptDescr = - [ - Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", - Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", - Option [] ["preproc"] (ReqArg preproc "CMD") - (unlines ["Use CMD to preprocess input files.", - "Multiple preprocessors can be used by giving this option multiple times."]), - Option [] ["stem"] (onOff (optimize OptStem) True) "Perform stem-suffix analysis (default on).", - Option [] ["cse"] (onOff (optimize OptCSE) True) "Perform common sub-expression elimination (default on).", - Option [] ["parser"] (onOff parser True) "Build parser (default on).", - Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar." - ] - where - addLibDir x o = return $ o { optLibraryPath = x:optLibraryPath o } - setLibPath x o = return $ o { optLibraryPath = splitInModuleSearchPath x } - preproc x o = return $ o { optPreprocessors = optPreprocessors o ++ [x] } - optimize x b o = return $ o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) } - parser x o = return $ o { optBuildParser = x } - language x o = return $ o { optSpeechLanguage = Just x } - -optDescr :: [OptDescr (Options -> Err Options)] -optDescr = - [ - Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", - Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", - Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo.", - Option ['V'] ["version"] (NoArg (mode Version)) "Display GF version number.", - Option ['?','h'] ["help"] (NoArg (mode Help)) "Show help message.", - Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.", - Option ['q'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", - Option [] ["batch"] (NoArg (mode Compiler)) "Run in batch compiler mode.", - Option [] ["interactive"] (NoArg (mode Interactive)) "Run in interactive mode (default).", - Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.", - Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).", - Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).", - Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.", - Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", - Option ['f'] ["output-format"] (ReqArg outFmt "FMT") - (unlines ["Output format. FMT can be one of:", - "Multiple concrete: gfcc (default), gar, js, ...", - "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", - "Abstract only: haskell, ..."]), - Option ['n'] ["output-name"] (ReqArg outName "NAME") - ("Use NAME as the name of the output. This is used in the output file names, " - ++ "with suffixes depending on the formats, and, when relevant, " - ++ "internally in the output."), - Option ['o'] ["output-file"] (ReqArg outFile "FILE") - "Save output in FILE (default is out.X, where X depends on output format.", - Option ['D'] ["output-dir"] (ReqArg outDir "DIR") - "Save output files (other than .gfc files) in DIR.", - Option [] ["src","force-recomp"] (NoArg (forceRecomp True)) - "Always recompile from source, i.e. disable recompilation checking.", - Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", - Option [] ["startcat"] (ReqArg startcat "CAT") "Use CAT as the start category in the generated grammar." - ] ++ map (fmap onModuleOptions) moduleOptDescr - where phase x o = return $ o { optStopAfterPhase = x } - mode x o = return $ o { optMode = x } - verbosity mv o = case mv of - Nothing -> return $ o { optVerbosity = 3 } - Just v -> case reads v of - [(i,"")] | i >= 0 -> return $ o { optVerbosity = i } - _ -> fail $ "Bad verbosity: " ++ show v - cpu x o = return $ o { optShowCPUTime = x } - emitGFO x o = return $ o { optEmitGFO = x } - gfoDir x o = return $ o { optGFODir = x } - outFmt x o = readOutputFormat x >>= \f -> - return $ o { optOutputFormats = optOutputFormats o ++ [f] } - outName x o = return $ o { optOutputName = Just x } - outFile x o = return $ o { optOutputFile = Just x } - outDir x o = return $ o { optOutputDir = x } - forceRecomp x o = return $ o { optForceRecomp = x } - prob x o = return $ o { optProb = x } - startcat x o = return $ o { optStartCategory = Just x } - -onModuleOptions :: Monad m => (ModuleOptions -> m ModuleOptions) -> Options -> m Options -onModuleOptions f o = do mo' <- f (optModuleOptions o) - return $ o { optModuleOptions = mo' } - -instance Functor OptDescr where - fmap f (Option cs ss d s) = Option cs ss (fmap f d) s - -instance Functor ArgDescr where - fmap f (NoArg x) = NoArg (f x) - fmap f (ReqArg g s) = ReqArg (f . g) s - fmap f (OptArg g s) = OptArg (f . g) s - -outputFormats :: [(String,OutputFormat)] -outputFormats = - [("gfcc", FmtGFCC), - ("js", FmtJS)] - -onOff :: Monad m => (Bool -> (a -> m a)) -> Bool -> ArgDescr (a -> m a) -onOff f def = OptArg g "[on,off]" - where g ma x = do b <- maybe (return def) readOnOff ma - f b x - readOnOff x = case map toLower x of - "on" -> return True - "off" -> return False - _ -> fail $ "Expected [on,off], got: " ++ show x - -readOutputFormat :: Monad m => String -> m OutputFormat -readOutputFormat s = - maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats diff --git a/src-3.0/GF/Devel/TC.hs b/src-3.0/GF/Devel/TC.hs index bdb0a6fd1..3d97d4b56 100644 --- a/src-3.0/GF/Devel/TC.hs +++ b/src-3.0/GF/Devel/TC.hs @@ -24,7 +24,6 @@ module GF.Devel.TC (AExp(..), import GF.Data.Operations import GF.Grammar.Predef import GF.Grammar.Abstract -import GF.Devel.AbsCompute import Control.Monad import Data.List (sortBy) diff --git a/src-3.0/GF/Devel/TestGF3.hs b/src-3.0/GF/Devel/TestGF3.hs deleted file mode 100644 index da4b5c8f6..000000000 --- a/src-3.0/GF/Devel/TestGF3.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import GF.Devel.Compile.GFC - -import System (getArgs) - -main = do - xx <- getArgs - mainGFC xx diff --git a/src-3.0/GF/Devel/TypeCheck.hs b/src-3.0/GF/Devel/TypeCheck.hs index 818b48a10..90edff8b0 100644 --- a/src-3.0/GF/Devel/TypeCheck.hs +++ b/src-3.0/GF/Devel/TypeCheck.hs @@ -13,31 +13,16 @@ ----------------------------------------------------------------------------- module GF.Devel.TypeCheck (-- * top-level type checking functions; TC should not be called directly. - annotate, annotateIn, - justTypeCheck, checkIfValidExp, - reduceConstraints, - splitConstraints, - possibleConstraints, - reduceConstraintsNode, - performMetaSubstNode, - -- * some top-level batch-mode checkers for the compiler - justTypeCheckSrc, - grammar2theorySrc, checkContext, checkTyp, checkEquation, checkConstrs, - editAsTermCommand, - exp2termCommand, - exp2termlistCommand, - tree2termlistCommand ) where import GF.Data.Operations import GF.Data.Zipper import GF.Grammar.Abstract -import GF.Devel.AbsCompute import GF.Grammar.Refresh import GF.Grammar.LookAbs import qualified GF.Grammar.Lookup as Lookup --- @@ -49,147 +34,10 @@ import GF.Grammar.Unify --- import Control.Monad (foldM, liftM, liftM2) import Data.List (nub) --- --- top-level type checking functions; TC should not be called directly. - -annotate :: GFCGrammar -> Exp -> Err Tree -annotate gr exp = annotateIn gr [] exp Nothing - --- | type check in empty context, return a list of constraints -justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints -justTypeCheck gr e v = do - (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v - constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0 - return $ fst $ splitConstraints gr constrs1 - --- | type check in empty context, return the expression itself if valid -checkIfValidExp :: GFCGrammar -> Exp -> Err Exp -checkIfValidExp gr e = do - (_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e - constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0 - ifNull (return e) (Bad . unwords . prConstrs) constrs1 - -annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree -annotateIn gr gamma exp = maybe (infer exp) (check exp) where - infer e = do - (a,_,cs) <- inferExp theory env e - aexp2treeC (a,cs) - check e v = do - (a,cs) <- checkExp theory env e v - aexp2treeC (a,cs) - env = initTCEnv gamma - theory = grammar2theory gr - aexp2treeC (a,c) = do - c' <- reduceConstraints (lookupAbsDef gr) (length gamma) c - aexp2tree (a,c') - -- | invariant way of creating TCEnv from context initTCEnv gamma = (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) --- | process constraints after eqVal by computing by defs -reduceConstraints :: LookDef -> Int -> Constraints -> Err Constraints -reduceConstraints look i = liftM concat . mapM redOne where - redOne (u,v) = do - u' <- computeVal look u - v' <- computeVal look v - eqVal i u' v' - -computeVal :: LookDef -> Val -> Err Val -computeVal look v = case v of - VClos g@(_:_) e -> do - e' <- compt (map fst g) e --- bindings of g in e? - whnf $ VClos g e' -{- ---- - _ -> do ---- how to compute a Val, really?? - e <- val2exp v - e' <- compt [] e - whnf $ vClos e' --} - VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf - _ -> whnf v - where - compt = computeAbsTermIn look - compv = computeVal look - --- | take apart constraints that have the form (? <> t), usable as solutions -splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst) -splitConstraints gr = splitConstraintsGen (lookupAbsDef gr) - -splitConstraintsSrc :: Grammar -> Constraints -> (Constraints,MetaSubst) -splitConstraintsSrc gr = splitConstraintsGen (Lookup.lookupAbsDef gr) - -splitConstraintsGen :: LookDef -> Constraints -> (Constraints,MetaSubst) -splitConstraintsGen look cs = csmsu where - - csmsu = (nub [(a,b) | (a,b) <- csf1,a /= b],msf1) - (csf1,msf1) = unif (csf,msf) -- alternative: filter first - (csf,msf) = foldr mkOne ([],[]) cs - - csmsf = foldr mkOne ([],msu) csu - (csu,msu) = unif (cs1,[]) -- alternative: unify first - - cs1 = errVal cs $ reduceConstraints look 0 cs - - mkOne (u,v) = case (u,v) of - (VClos g (Meta m), v) | null g -> sub m v - (v, VClos g (Meta m)) | null g -> sub m v - -- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG - c -> con c - con c (cs,ms) = (c:cs,ms) - sub m v (cs,ms) = (cs,(m,v):ms) - - unifo = id -- alternative: don't use unification - - unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification - (cs',ms') <- unifyVal cs - return (cs', ms' ++ ms) - -performMetaSubstNode :: MetaSubst -> TrNode -> TrNode -performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let - v' = metaSubstVal v - b' = [(x,metaSubstVal v) | (x,v) <- b] - c' = [(u',v') | (u,v) <- c, - let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v'] - in N (b',a,v',(c',m),s) - where - metaSubstVal u = errVal u $ whnf $ case u of - VApp f a -> VApp (metaSubstVal f) (metaSubstVal a) - VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e) - _ -> u - metaSubstExp e = case e of - Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst - _ -> composSafeOp metaSubstExp e - -reduceConstraintsNode :: GFCGrammar -> TrNode -> TrNode -reduceConstraintsNode gr = changeConstrs red where - red cs = errVal cs $ reduceConstraints (lookupAbsDef gr) 0 cs - --- | weak heuristic to narrow down menus; not used for TC. 15\/11\/2001. --- the age-old method from GF 0.9 -possibleConstraints :: GFCGrammar -> Constraints -> Bool -possibleConstraints gr = and . map (possibleConstraint gr) - -possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool -possibleConstraint gr (u,v) = errVal True $ do - u' <- val2exp u >>= compute gr - v' <- val2exp v >>= compute gr - return $ cts u' v' - where - cts t u = isUnknown t || isUnknown u || case (t,u) of - (Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d) - (QC m c, QC n d) -> c == d - (App f a, App g b) -> cts f g && cts a b - (Abs x b, Abs y c) -> cts b c - (Prod x a f, Prod y b g) -> cts a b && cts f g - (_ , _) -> False - - isUnknown t = case t of - Vr _ -> True - Meta _ -> True - _ -> False - - notCan = not . isPrimitiveFun gr - -- interface to TC type checker type2val :: Type -> Val @@ -227,13 +75,6 @@ aexp2tree (aexp,cs) = do return ([],AtM m,v',[]) _ -> Bad "illegal tree" -- AProd -grammar2theory :: GFCGrammar -> Theory -grammar2theory gr (m,f) = case lookupFunType gr m f of - Ok t -> return $ type2val t - Bad s -> case lookupCatContext gr m f of - Ok cont -> return $ cont2val cont - _ -> Bad s - cont2exp :: Context -> Exp cont2exp c = mkProd (c, eType, []) -- to check a context @@ -242,9 +83,9 @@ cont2val = type2val . cont2exp -- some top-level batch-mode checkers for the compiler -justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints -justTypeCheckSrc gr e v = do - (_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v +justTypeCheck :: Grammar -> Exp -> Val -> Err Constraints +justTypeCheck gr e v = do + (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v return $ filter notJustMeta constrs0 ---- return $ fst $ splitConstraintsSrc gr constrs0 ---- this change was to force proper tc of abstract modules. @@ -254,10 +95,10 @@ notJustMeta (c,k) = case (c,k) of (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False _ -> True -grammar2theorySrc :: Grammar -> Theory -grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of +grammar2theory :: Grammar -> Theory +grammar2theory gr (m,f) = case lookupFunType gr m f of Ok t -> return $ type2val t - Bad s -> case lookupCatContextSrc gr m f of + Bad s -> case lookupCatContext gr m f of Ok cont -> return $ cont2val cont _ -> Bad s @@ -265,47 +106,14 @@ checkContext :: Grammar -> Context -> [String] checkContext st = checkTyp st . cont2exp checkTyp :: Grammar -> Type -> [String] -checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType +checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType checkEquation :: Grammar -> Fun -> Trm -> [String] checkEquation gr (m,fun) def = err singleton id $ do - typ <- lookupFunTypeSrc gr m fun ----- cs <- checkEqs (grammar2theorySrc gr) (initTCEnv []) ((m,fun),def) (vClos typ) - cs <- justTypeCheckSrc gr def (vClos typ) - let cs1 = filter notJustMeta cs ----- filter (not . possibleConstraint gr) cs ---- + typ <- lookupFunType gr m fun + cs <- justTypeCheck gr def (vClos typ) + let cs1 = filter notJustMeta cs return $ ifNull [] (singleton . prConstraints) cs1 checkConstrs :: Grammar -> Cat -> [Ident] -> [String] checkConstrs gr cat _ = [] ---- check constructors! - - - - - - -{- ---- -err singleton concat . mapM checkOne where - checkOne con = do - typ <- lookupFunType gr con - typ' <- computeAbsTerm gr typ - vcat <- valCat typ' - return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con] --} - -editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp] -editAsTermCommand gr c e = err (const []) singleton $ do - t <- annotate gr $ refreshMetas [] e - t' <- c $ tree2loc t - return $ tree2exp $ loc2tree t' - -exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree -exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do - let exp = tree2exp t - exp2 <- f exp - annotate gr exp2 - -exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree] -exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp - -tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree] -tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f diff --git a/src-3.0/GF/Embed/EmbedAPI.hs b/src-3.0/GF/Embed/EmbedAPI.hs deleted file mode 100644 index 43e4f2546..000000000 --- a/src-3.0/GF/Embed/EmbedAPI.hs +++ /dev/null @@ -1,114 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : EmbedAPI --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Reduced Application Programmer's Interface to GF, meant for --- embedded GF systems. AR 10/5/2005 ------------------------------------------------------------------------------ - -module GF.Embed.EmbedAPI where - -import GF.Compile.ShellState (ShellState,grammar2shellState,canModules,stateGrammarOfLang,abstract,grammar,firstStateGrammar,allLanguages,allCategories,stateOptions,firstAbsCat) -import GF.UseGrammar.Linear (linTree2string) -import GF.UseGrammar.GetTree (string2tree) -import GF.Embed.EmbedParsing (parseString) -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_) -import GF.Grammar.Values (tree2exp) -import GF.Grammar.TypeCheck (annotate) -import GF.Canon.GetGFC (getCanonGrammar) -import GF.Infra.Modules (emptyMGrammar) -import GF.CF.CFIdent (string2CFCat) -import GF.Infra.UseIO -import GF.Data.Operations -import GF.Infra.Option (noOptions,useUntokenizer,options,iOpt) -import GF.Infra.Ident (prIdent) -import GF.Embed.EmbedCustom - --- This API is meant to be used when embedding GF grammars in Haskell --- programs. The embedded system is supposed to use the --- .gfcm grammar format, which is first produced by the gf program. - ---------------------------------------------------- --- Interface ---------------------------------------------------- - -type MultiGrammar = ShellState -type Language = String -type Category = String -type Tree = Trm - -file2grammar :: FilePath -> IO MultiGrammar - -linearize :: MultiGrammar -> Language -> Tree -> String -parse :: MultiGrammar -> Language -> Category -> String -> [Tree] - -linearizeAll :: MultiGrammar -> Tree -> [String] -linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)] - -parseAll :: MultiGrammar -> Category -> String -> [[Tree]] -parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])] - -readTree :: MultiGrammar -> String -> Tree -showTree :: Tree -> String - -languages :: MultiGrammar -> [Language] -categories :: MultiGrammar -> [Category] - -startCat :: MultiGrammar -> Category - ---------------------------------------------------- --- Implementation ---------------------------------------------------- - -file2grammar file = do - can <- useIOE (error "cannot parse grammar file") $ getCanonGrammar file - return $ errVal (error "cannot build multigrammar") $ - grammar2shellState (options [iOpt "docf"]) (can,emptyMGrammar) - -linearize mgr lang = - untok . - linTree2string noMark (canModules mgr) (zIdent lang) . - errVal (error "illegal tree") . - annotate gr - where - gr = grammar sgr - sgr = stateGrammarOfLang mgr (zIdent lang) - untok = customOrDefault (stateOptions sgr) useUntokenizer customUntokenizer sgr - -parse mgr lang cat = - map tree2exp . - errVal [] . - parseString (stateOptions sgr) sgr cfcat - where - sgr = stateGrammarOfLang mgr (zIdent lang) - cfcat = string2CFCat abs cat - abs = maybe (error "no abstract syntax") prIdent $ abstract mgr - -linearizeAll mgr = map snd . linearizeAllLang mgr -linearizeAllLang mgr t = [(lang,linearize mgr lang t) | lang <- languages mgr] - -parseAll mgr cat = map snd . parseAllLang mgr cat - -parseAllLang mgr cat s = - [(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)] - -readTree mgr s = tree2exp $ string2tree (firstStateGrammar mgr) s - -showTree t = prt_ t - -languages mgr = [prt_ l | l <- allLanguages mgr] - -categories mgr = [prt_ c | (_,c) <- allCategories mgr] - -startCat = prt_ . snd . firstAbsCat noOptions . firstStateGrammar diff --git a/src-3.0/GF/Embed/EmbedCustom.hs b/src-3.0/GF/Embed/EmbedCustom.hs deleted file mode 100644 index f315441c5..000000000 --- a/src-3.0/GF/Embed/EmbedCustom.hs +++ /dev/null @@ -1,113 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : EmbedCustom --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- A database for customizable lexers and unlexers. Reduced version of --- GF.API, intended for embedded GF grammars. - ------------------------------------------------------------------------------ - -module GF.Embed.EmbedCustom where - -import GF.Data.Operations -import GF.Text.Text -import GF.UseGrammar.Tokenize -import GF.UseGrammar.Morphology -import GF.Infra.Option -import GF.CF.CFIdent -import GF.Compile.ShellState -import Data.Char - --- | useTokenizer, \"-lexer=x\" -customTokenizer :: CustomData (StateGrammar -> String -> [CFTok]) - --- | useUntokenizer, \"-unlexer=x\" --- should be from token list to string -customUntokenizer :: CustomData (StateGrammar -> 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)) - -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 - -customTokenizer = - customData "Tokenizers, selected by option -lexer=x" $ - [ - (strCI "words", const $ tokWords) - ,(strCI "literals", const $ tokLits) - ,(strCI "vars", const $ tokVars) - ,(strCI "chars", const $ map (tS . singleton)) - ,(strCI "code", const $ lexHaskell) - ,(strCI "codevars", lexHaskellVar . stateIsWord) - ,(strCI "text", const $ lexText) - ,(strCI "unglue", \gr -> map tS . decomposeWords (stateMorpho gr)) - ,(strCI "codelit", lexHaskellLiteral . stateIsWord) - ,(strCI "textlit", lexTextLiteral . stateIsWord) - ,(strCI "codeC", const $ lexC2M) - ,(strCI "codeCHigh", const $ 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 "reverse", const $ reverse) - ,(strCI "bind", const $ performBinds) -- backward compat --- add your own untokenizers here - ] - diff --git a/src-3.0/GF/Embed/EmbedParsing.hs b/src-3.0/GF/Embed/EmbedParsing.hs deleted file mode 100644 index 43909f355..000000000 --- a/src-3.0/GF/Embed/EmbedParsing.hs +++ /dev/null @@ -1,65 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : EmbedParsing --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- just one parse method, for use in embedded GF systems ------------------------------------------------------------------------------ - -module GF.Embed.EmbedParsing 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 GF.UseGrammar.Tokenize -import GF.CF.Profile -import GF.Infra.Option -import GF.Compile.ShellState -import GF.Embed.EmbedCustom -import GF.CF.PPrCF (prCFTree) -import qualified GF.Parsing.GFC as New - - --- import qualified GF.Parsing.GFC as New - -import GF.Data.Operations - -import Data.List (nub) -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 - (ts,(_,ss)) <- checkStart $ parseStringC os sg cat s - return (ts,unlines ss) - -parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree] -parseStringC opts0 sg cat s = do - let opts = unionOptions opts0 $ stateOptions sg - algorithm = "f" -- default algorithm: FCFG - strategy = "bottomup" - tokenizer = customOrDefault opts useTokenizer customTokenizer sg - toks = tokenizer s - ts <- checkErr $ New.parse algorithm strategy (pInfo sg) (absId sg) cat toks - checkErr $ allChecks $ map (annotate (stateGrammarST sg) . refreshMetas []) ts - diff --git a/src-3.0/GF/Embed/TemplateApp.hs b/src-3.0/GF/Embed/TemplateApp.hs deleted file mode 100644 index f8722691f..000000000 --- a/src-3.0/GF/Embed/TemplateApp.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Main where - -import GF.Embed.EmbedAPI -import System - --- Simple translation application built on EmbedAPI. AR 7/10/2005 - -main :: IO () -main = do - file:_ <- getArgs - grammar <- file2grammar file - translate grammar - -translate :: MultiGrammar -> IO () -translate grammar = do - s <- getLine - if s == "quit" then return () else do - treat grammar s - translate grammar - -treat :: MultiGrammar -> String -> IO () -treat grammar s = putStrLn $ case comm of - ["lin"] -> unlines $ linearizeAll grammar $ readTree grammar rest - ["lin",lang] -> linearize grammar lang $ readTree grammar rest - ["parse",cat] -> unlines $ map showTree $ concat $ parseAll grammar cat rest - ["parse",lang,cat] -> unlines $ map showTree $ parse grammar lang cat rest - ["langs"] -> unwords $ languages grammar - ["cats"] -> unwords $ categories grammar - ["help"] -> helpMsg - _ -> "command not interpreted: " ++ s - where - (comm,rest) = (words c,drop 1 r) where - (c,r) = span (/=':') s - -helpMsg = unlines [ - "lin : ", - "lin : ", - "parse : ", - "parse : ", - "langs", - "cats", - "help", - "quit" - ] diff --git a/src-3.0/GF/Formalism/CFG.hs b/src-3.0/GF/Formalism/CFG.hs deleted file mode 100644 index c38adb4e2..000000000 --- a/src-3.0/GF/Formalism/CFG.hs +++ /dev/null @@ -1,50 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/11 13:52:49 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- CFG formalism ------------------------------------------------------------------------------ - -module GF.Formalism.CFG where - -import GF.Formalism.Utilities -import GF.Infra.Print -import GF.Data.Assoc (accumAssoc) -import GF.Data.SortedList (groupPairs) -import GF.Data.Utilities (mapSnd) - ------------------------------------------------------------- --- type definitions - -type CFGrammar c n t = [CFRule c n t] -data CFRule c n t = CFRule c [Symbol c t] n - deriving (Eq, Ord, Show) - -type CFChart c n t = CFGrammar (Edge c) n t - - ------------------------------------------------------------- --- building syntax charts from grammars - -grammar2chart :: (Ord n, Ord e) => CFGrammar e n t -> SyntaxChart n e -grammar2chart cfchart = accumAssoc groupSyntaxNodes $ - [ (lhs, SNode name (filterCats rhs)) | - CFRule lhs rhs name <- cfchart ] - - ----------------------------------------------------------------------- --- pretty-printing - -instance (Print n, Print c, Print t) => Print (CFRule c n t) where - prt (CFRule cat rhs name) = prt name ++ " : " ++ prt cat ++ - ( if null rhs then "" - else " --> " ++ prtSep " " rhs ) - prtList = prtSep "\n" - - diff --git a/src-3.0/GF/Formalism/GCFG.hs b/src-3.0/GF/Formalism/GCFG.hs deleted file mode 100644 index 5242081c7..000000000 --- a/src-3.0/GF/Formalism/GCFG.hs +++ /dev/null @@ -1,47 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Basic GCFG formalism (derived from Pollard 1984) ------------------------------------------------------------------------------ - -module GF.Formalism.GCFG where - -import GF.Formalism.Utilities (SyntaxChart) -import GF.Data.Assoc (assocMap, accumAssoc) -import GF.Data.SortedList (nubsort, groupPairs) -import GF.Infra.PrintClass - ----------------------------------------------------------------------- - -type Grammar c n l t = [Rule c n l t] -data Rule c n l t = Rule (Abstract c n) (Concrete l t) - deriving (Eq, Ord, Show) - -data Abstract cat name = Abs cat [cat] name - deriving (Eq, Ord, Show) -data Concrete lin term = Cnc lin [lin] term - deriving (Eq, Ord, Show) - ----------------------------------------------------------------------- - -instance (Print c, Print n, Print l, Print t) => Print (Rule n c l t) where - prt (Rule abs cnc) = prt abs ++ " := " ++ prt cnc - prtList = prtSep "\n" - -instance (Print c, Print n) => Print (Abstract c n) where - prt (Abs cat args name) = prt name ++ ". " ++ prt cat ++ - ( if null args then "" - else " --> " ++ prtSep " " args ) - -instance (Print l, Print t) => Print (Concrete l t) where - prt (Cnc lcat args term) = prt term - ++ " : " ++ prt lcat ++ - ( if null args then "" - else " / " ++ prtSep " " args) diff --git a/src-3.0/GF/Formalism/MCFG.hs b/src-3.0/GF/Formalism/MCFG.hs deleted file mode 100644 index e6aa965e7..000000000 --- a/src-3.0/GF/Formalism/MCFG.hs +++ /dev/null @@ -1,58 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:45 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- Definitions of multiple context-free grammars ------------------------------------------------------------------------------ - -module GF.Formalism.MCFG where - -import Control.Monad (liftM) -import Data.List (groupBy) - -import GF.Formalism.Utilities -import GF.Formalism.GCFG - -import GF.Infra.PrintClass - - ------------------------------------------------------------- --- grammar types - --- | the lables in the linearization record should be in the same --- order as specified by the linearization type @[lbl]@ -type MCFGrammar cat name lbl tok = Grammar cat name [lbl] [Lin cat lbl tok] -type MCFRule cat name lbl tok = Rule cat name [lbl] [Lin cat lbl tok] - --- | variants are encoded as several linearizations with the same label -data Lin cat lbl tok = Lin lbl [Symbol (cat, lbl, Int) tok] - deriving (Eq, Ord, Show) - -instantiateArgs :: [cat] -> Lin cat' lbl tok -> Lin cat lbl tok -instantiateArgs args (Lin lbl lin) = Lin lbl (map instSym lin) - where instSym = mapSymbol instCat id - instCat (_, lbl, nr) = (args !! nr, lbl, nr) - -expandVariants :: Eq lbl => MCFRule cat name lbl tok -> [MCFRule cat name lbl tok] -expandVariants (Rule abs (Cnc typ typs lins)) = liftM (Rule abs . Cnc typ typs) $ - expandLins lins - where expandLins = sequence . groupBy eqLbl - eqLbl (Lin l1 _) (Lin l2 _) = l1 == l2 - - ------------------------------------------------------------- --- pretty-printing - -instance (Print c, Print l, Print t) => Print (Lin c l t) where - prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin) - where prArg (cat, lbl, nr) = prt cat ++ "@" ++ prt nr ++ prt lbl - prtList = prtBefore "\n\t" - - - diff --git a/src-3.0/GF/Formalism/SimpleGFC.hs b/src-3.0/GF/Formalism/SimpleGFC.hs deleted file mode 100644 index 22298eece..000000000 --- a/src-3.0/GF/Formalism/SimpleGFC.hs +++ /dev/null @@ -1,268 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/11 14:11:46 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.7 $ --- --- Simplistic GFC format ------------------------------------------------------------------------------ - -module GF.Formalism.SimpleGFC where - -import Control.Monad (liftM) -import qualified GF.Canon.AbsGFC as AbsGFC -import qualified GF.Infra.Ident as Ident -import GF.Formalism.GCFG -import GF.Infra.Print - ----------------------------------------------------------------------- --- * basic (leaf) types - -type Constr = AbsGFC.CIdent -type Var = Ident.Ident -type Label = AbsGFC.Label - -anyVar :: Var -anyVar = Ident.identW - ----------------------------------------------------------------------- --- * simple GFC - -type SimpleGrammar c n t = Grammar (Decl c) n (LinType c t) (Maybe (Term c t)) -type SimpleRule c n t = Rule (Decl c) n (LinType c t) (Maybe (Term c t)) - --- ** dependent type declarations - --- 'Decl x c ts' == x is of type (c applied to ts) --- data Decl c = Decl Var c [TTerm] --- deriving (Eq, Ord, Show) - --- | 'Decl x t' == 'x' is of type 't' -data Decl c = Decl Var (AbsType c) deriving (Eq, Ord, Show) --- | '[t1..tn] ::--> t' == 't1 -> ... -> tn -> t' -data AbsType c = [FOType c] ::--> FOType c deriving (Eq, Ord, Show) --- | 'c ::@ [t1..tn]' == '(c t1 ... tn)' -data FOType c = c ::@ [TTerm] deriving (Eq, Ord, Show) - --- including second order functions: --- (A -> B) ==> Decl _ ([A ::@ []] ::--> (B ::@ [])) --- (x : A -> B -> C) ==> Decl x ([A ::@ [], B ::@ []] ::--> (C ::@ [])) --- (y : A t x -> B (t x)) ==> Decl y ([A ::@ [t:@[],TVar x]] ::--> (B ::@ [t:@[TVar x]])) - - -data TTerm = Constr :@ [TTerm] - | TVar Var - deriving (Eq, Ord, Show) - -decl2cat :: Decl c -> c -decl2cat (Decl _ (_ ::--> (cat ::@ _))) = cat - -varsInTTerm :: TTerm -> [Var] -varsInTTerm tterm = vars tterm [] - where vars (TVar x) = (x:) - vars (_ :@ ts) = foldr (.) id $ map vars ts - -tterm2term :: TTerm -> Term c t -tterm2term (con :@ terms) = con :^ map tterm2term terms --- tterm2term (TVar x) = Var x -tterm2term term = error $ "tterm2term: illegal term" - -term2tterm :: Term c t -> TTerm -term2tterm (con :^ terms) = con :@ map term2tterm terms --- term2tterm (Var x) = TVar x -term2tterm term = error $ "term2tterm: illegal term" - --- ** linearization types and terms - -data LinType c t = RecT [(Label, LinType c t)] - | TblT [Term c t] (LinType c t) - | ConT [Term c t] - | StrT - deriving (Eq, Ord, Show) - -isBaseType :: LinType c t -> Bool -isBaseType (ConT _) = True -isBaseType (StrT) = True -isBaseType _ = False - -data Term c t - = Arg Int c (Path c t) -- ^ argument variable, the 'Path' is a path - -- pointing into the term - | Constr :^ [Term c t] -- ^ constructor - | Rec [(Label, Term c t)] -- ^ record - | Term c t :. Label -- ^ record projection - | Tbl [(Term c t, Term c t)] -- ^ table of patterns\/terms - | Term c t :! Term c t -- ^ table selection - | Variants [Term c t] -- ^ variants - | Term c t :++ Term c t -- ^ concatenation - | Token t -- ^ single token - | Empty -- ^ empty string - ---- | Wildcard -- ^ wildcard pattern variable - ---- | Var Var -- ^ bound pattern variable - - -- Res CIdent -- ^ resource identifier - -- Int Integer -- ^ integer - deriving (Eq, Ord, Show) - --- ** calculations on terms - -(+.) :: Term c t -> Label -> Term c t -Variants terms +. lbl = variants $ map (+. lbl) terms -Rec record +. lbl = maybe err id $ lookup lbl record - where err = error $ "(+.): label not in record" -Arg arg cat path +. lbl = Arg arg cat (path ++. lbl) -term +. lbl = term :. lbl - -(+!) :: (Eq c, Eq t) => Term c t -> Term c t -> Term c t -Variants terms +! pat = variants $ map (+! pat) terms -term +! Variants pats = variants $ map (term +!) pats -term +! arg@(Arg _ _ _) = term :! arg -Arg arg cat path +! pat = Arg arg cat (path ++! pat) --- cannot handle tables with pattern variales or wildcards (yet): -term@(Tbl table) +! pat = maybe (term :! pat) id $ lookup pat table -term +! pat = term :! pat - -{- does not work correctly: -lookupTbl term [] _ = term -lookupTbl _ ((Wildcard, term) : _) _ = term -lookupTbl _ ((Var x, term) : _) pat = subst x pat term -lookupTbl _ ((pat', term) : _) pat | pat == pat' = term -lookupTbl term (_ : tbl) pat = lookupTbl term tbl pat - -subst x a (Arg n c (Path path)) = Arg n c (Path (map substP path)) - where substP (Right (Var y)) | x==y = Right a - substP p = p -subst x a (con :^ ts) = con :^ map (subst x a) ts -subst x a (Rec rec) = Rec [ (l, subst x a t) | (l, t) <- rec ] -subst x a (t :. l) = subst x a t +. l -subst x a (Tbl tbl) = Tbl [ (subst x a p, subst x a t) | (p, t) <- tbl ] -subst x a (t :! s) = subst x a t +! subst x a s -subst x a (Variants ts) = variants $ map (subst x a) ts -subst x a (t1 :++ t2) = subst x a t1 ?++ subst x a t2 -subst x a (Var y) | x==y = a -subst x a t = t --} - -(?++) :: Term c t -> Term c t -> Term c t -Variants terms ?++ term = variants $ map (?++ term) terms -term ?++ Variants terms = variants $ map (term ?++) terms -Empty ?++ term = term -term ?++ Empty = term -term1 ?++ term2 = term1 :++ term2 - -variants :: [Term c t] -> Term c t -variants terms0 = case concatMap flatten terms0 of - [term] -> term - terms -> Variants terms - where flatten (Variants ts) = ts - flatten t = [t] - --- ** enumerations - -enumerateTerms :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t] -enumerateTerms arg (StrT) = maybe err return arg - where err = error "enumeratePatterns: parameter type should not be string" -enumerateTerms arg (ConT terms) = terms -enumerateTerms arg (RecT rtype) - = liftM Rec $ mapM enumAssign rtype - where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype -enumerateTerms arg (TblT terms ctype) - = liftM Tbl $ mapM enumCase terms - where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype - -enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t] -enumeratePatterns t = enumerateTerms Nothing t - ----------------------------------------------------------------------- --- * paths of record projections and table selections - --- | Note that the list of labels/selection terms is /reversed/ -newtype Path c t = Path [Either Label (Term c t)] deriving (Eq, Ord, Show) - -emptyPath :: Path c t -emptyPath = Path [] - --- ** calculations on paths - -(++.) :: Path c t -> Label -> Path c t -Path path ++. lbl = Path (Left lbl : path) - -(++!) :: Path c t -> Term c t -> Path c t -Path path ++! sel = Path (Right sel : path) - -lintypeFollowPath :: (Print c,Print t) => Path c t -> LinType c t -> LinType c t -lintypeFollowPath (Path path0) ctype0 = follow (reverse path0) ctype0 - where follow [] ctype = ctype - follow (Right pat : path) (TblT _ ctype) = follow path ctype - follow (Left lbl : path) (RecT rec) - = maybe err (follow path) $ lookup lbl rec - where err = error $ "lintypeFollowPath: label not in record type" - ++ "\nOriginal Path: " ++ prt (Path path0) - ++ "\nOriginal CType: " ++ prt ctype0 - ++ "\nCurrent Label: " ++ prt lbl - ++ "\nCurrent RType: " ++ prt (RecT rec) - --- by AR for debugging 23/11/2005 - -termFollowPath :: (Eq c, Eq t) => Path c t -> Term c t -> Term c t -termFollowPath (Path path0) = follow (reverse path0) - where follow [] term = term - follow (Right pat : path) term = follow path (term +! pat) - follow (Left lbl : path) term = follow path (term +. lbl) - -lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t] -lintype2paths path (ConT _) = [] -lintype2paths path (StrT) = [ path ] -lintype2paths path (RecT rec) = concat [ lintype2paths (path ++. lbl) ctype | - (lbl, ctype) <- rec ] -lintype2paths path (TblT pts vt)= concat [ lintype2paths (path ++! pat) vt | - pat <- pts ] - ----------------------------------------------------------------------- --- * pretty-printing - -instance Print c => Print (Decl c) where - prt (Decl var typ) | var == anyVar = prt typ - | otherwise = "(?" ++ prt var ++ ":" ++ prt typ ++ ")" - -instance Print c => Print (AbsType c) where - prt ([] ::--> typ) = prt typ - prt (args ::--> typ) = "(" ++ prtAfter "->" args ++ prt typ ++ ")" - -instance Print c => Print (FOType c) where - prt (cat ::@ args) = prt cat ++ prtBefore " " args - -instance Print TTerm where - prt (con :@ args) - | null args = prt con - | otherwise = "(" ++ prt con ++ prtBefore " " args ++ ")" - prt (TVar var) = "?" ++ prt var - -instance (Print c, Print t) => Print (LinType c t) where - prt (RecT rec) = "{" ++ prtPairList ":" "; " rec ++ "}" - prt (TblT ts t2) = "([" ++ prtSep "|" ts ++ "] => " ++ prt t2 ++ ")" - prt (ConT ts) = "[" ++ prtSep "|" ts ++ "]" - prt (StrT) = "Str" - -instance (Print c, Print t) => Print (Term c t) where - prt (Arg n c p) = prt c ++ prt n ++ prt p - prt (c :^ []) = prt c - prt (c :^ ts) = "(" ++ prt c ++ prtBefore " " ts ++ ")" - prt (Rec rec) = "{" ++ prtPairList "=" "; " rec ++ "}" - prt (Tbl tbl) = "[" ++ prtPairList "=>" "; " tbl ++ "]" - prt (Variants ts) = "{| " ++ prtSep " | " ts ++ " |}" - prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2 - prt (Token t) = "'" ++ prt t ++ "'" - prt (Empty) = "[]" - prt (term :. lbl) = prt term ++ "." ++ prt lbl - prt (term :! sel) = prt term ++ "!" ++ prt sel --- prt (Wildcard) = "_" --- prt (Var var) = "?" ++ prt var - -instance (Print c, Print t) => Print (Path c t) where - prt (Path path) = concatMap prtEither (reverse path) - where prtEither (Left lbl) = "." ++ prt lbl - prtEither (Right patt) = "!" ++ prt patt diff --git a/src-3.0/GF/Fudgets/ArchEdit.hs b/src-3.0/GF/Fudgets/ArchEdit.hs deleted file mode 100644 index 5bc0dc84b..000000000 --- a/src-3.0/GF/Fudgets/ArchEdit.hs +++ /dev/null @@ -1,30 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : (Module) --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:46:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Fudgets.ArchEdit ( - fudlogueEdit, fudlogueWrite, fudlogueWriteUni - ) where - -import GF.Fudgets.CommandF -import GF.Fudgets.UnicodeF - --- architecture/compiler dependent definitions for unix/ghc, if Fudgets works. --- If not, use the modules in for-ghci - -fudlogueEdit font = fudlogueEditF ---- -fudlogueWrite = fudlogueWriteU -fudlogueWriteUni _ _ = do - putStrLn "sorry no unicode available in ghc" - - diff --git a/src-3.0/GF/Fudgets/CommandF.hs b/src-3.0/GF/Fudgets/CommandF.hs deleted file mode 100644 index 15af12215..000000000 --- a/src-3.0/GF/Fudgets/CommandF.hs +++ /dev/null @@ -1,134 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CommandF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:15 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- a graphical shell for any kind of GF with Zipper editing. AR 20\/8\/2001 ------------------------------------------------------------------------------ - -module GF.Fudgets.CommandF where - -import GF.Data.Operations - -import GF.UseGrammar.Session -import GF.Shell.Commands - -import Fudgets -import GF.Fudgets.FudgetOps - -import GF.Fudgets.EventF - --- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001 - -fudlogueEditF :: CEnv -> IO () -fudlogueEditF env = - fudlogue $ gfSizeP $ shellF ("GF 2.0- Fudget Editor") (gfF env) - -gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF - -( quitN : menusN : newN : transformN : filterN : displayN : - navigateN : viewN : outputN : saveN : _) = map show [1..] - -gfLayout = placeNL verticalP [generics,output,navigate,menus,transform] - where - generics = placeNL horizontalP (map leafNL - [newN,saveN,viewN,displayN,filterN,quitN]) - output = leafNL outputN - navigate = leafNL navigateN - menus = leafNL menusN - transform = leafNL transformN - -gfSizeP = spacerF (sizeS (Point 720 640)) - -gfOutputF env = - ((nameF outputN $ (writeFileF >+< textWindowF)) - >==< - (absF (saveSP "EMPTY") - >==< - (nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:") - >+< - mapF (displayJustStateIn env)))) - >==< - mapF Right - -gfCommandF :: CEnv -> F () SState -gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click) - -loopCommandsF :: CEnv -> F Command SState -loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env) - -mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState) -mapGfStateF env = mapstateF execFC (initSState) where - execFC e0 (Left c) = (e,[Right e,Left e]) where e = execECommand env c e0 - execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0 - -mkMenusF :: CEnv -> F SState Command -mkMenusF env = - nameF menusN $ - labAboveF "Select Action on Subterm" - (mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env)) - -getCommandsF env = - newF env >*< - viewF >*< - menuDisplayF env >*< - filterF >*< - navigateF >*< - transformF - -key2command ((key,_),_) = case key of - "Up" -> CBack 1 - "Down" -> CAhead 1 - "Left" -> CPrevMeta - "Right" -> CNextMeta - "space" -> CTop - - "d" -> CDelete - "u" -> CUndo - "v" -> CView - - _ -> CVoid - -transformF = - nameF transformN $ - mapF (either key2command id) >==< (keyboardF $ - placerF horizontalP $ - cPopupStringInputF CRefineParse "Parse" "" "Parse in concrete syntax" >*< - --- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF) - cPopupStringInputF CRefineWithTree "Term" "" "Parse term" >*< - cMenuF "Modify" termCommandMenu >*< - cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert" >*< - cButtonF CRefineRandom "Random" >*< - cButtonF CUndo "Undo" - ) - -quitButF = nameF quitN $ quitF >==< buttonF "Quit" - -newF env = nameF newN $ cMenuF "New" (newCatMenu env) -menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env -filterF = nameF filterN $ cMenuF "Filter" stringCommandMenu - -viewF = nameF viewN $ cButtonF CView "View" - -navigateF = - nameF navigateN $ - placerF horizontalP $ - cButtonF CPrevMeta "?<" >*< - cButtonF (CBack 1) "<" >*< - cButtonF CTop "Top" >*< - cButtonF CLast "Last" >*< - cButtonF (CAhead 1) ">" >*< - cButtonF CNextMeta ">?" - -cButtonF c s = mapF (const c) >==< buttonF s -cMenuF s css = menuF s css >==< mapF (\_ -> CVoid) - -cPopupStringInputF comm lab def msg = - mapF comm >==< popupStringInputF lab def msg >==< mapF (const []) - diff --git a/src-3.0/GF/Fudgets/EventF.hs b/src-3.0/GF/Fudgets/EventF.hs deleted file mode 100644 index 7ea058dfa..000000000 --- a/src-3.0/GF/Fudgets/EventF.hs +++ /dev/null @@ -1,51 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : EventF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Fudgets.EventF where -import AllFudgets - --- | The first string is the name of the key (e.g., "Down" for the down arrow key) --- --- The modifiers list shift, control and alt keys that were active while the --- key was pressed. --- --- The last string is the text produced by the key (for keys that produce --- printable characters, empty for control keys). -type KeyPress = ((String,[Modifiers]),String) - -keyboardF :: F i o -> F i (Either KeyPress o) -keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud - where - post (KeyEvent {type'=Pressed,keySym=sym,state=mods,keyLookup=s}) = - [((sym,mods),s)] - post _ = [] - - mask = [KeyPressMask, - EnterWindowMask, LeaveWindowMask -- because of CTT implementation - ] - --- | Output events: -oeventF em fud = eventF em (idLeftF fud) - --- | Feed events to argument fudget: -eventF eventmask = serCompLeftToRightF . groupF startcmds eventK - where - startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask], - XCmd $ ConfigureWindow [CWBorderWidth 0]] - eventK = K $ mapFilterSP route - where route = message low high - low (XEvt event) = Just (High (Left event)) - low _ = Nothing - high h = Just (High (Right h)) - diff --git a/src-3.0/GF/Fudgets/FudgetOps.hs b/src-3.0/GF/Fudgets/FudgetOps.hs deleted file mode 100644 index 4aba5eec5..000000000 --- a/src-3.0/GF/Fudgets/FudgetOps.hs +++ /dev/null @@ -1,59 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : FudgetOps --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:17 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- auxiliary Fudgets for GF syntax editor ------------------------------------------------------------------------------ - -module GF.Fudgets.FudgetOps where - -import Fudgets - --- save and display - -showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud - -saveF :: F a String -> F (Either String a) (Either (String,String) String) -saveF fud = - absF (saveSP "EMPTY") - >==< - (popupStringInputF "Save" "foo.tmp" "Save to file:" >+< fud) - -saveSP :: String -> SP (Either String String) (Either (String,String) String) -saveSP contents = getSP $ \msg -> case msg of - Left file -> putSP (Left (file,contents)) (saveSP contents) - Right string -> putSP (Right string) (saveSP string) - -textWindowF = writeOutputF - --- | to replace stringInputF by a pop-up slot behind a button -popupStringInputF :: String -> String -> String -> F String String -popupStringInputF label deflt msg = - mapF snd - >==< - (popupSizeP $ stringPopupF deflt) - >==< - mapF (\_ -> (Just msg,Nothing)) - >==< - decentButtonF label - >==< - mapF (\_ -> Click) - -decentButtonF = spacerF (sizeS (Point 80 20)) . buttonF - -popupSizeP = spacerF (sizeS (Point 240 100)) - ---- the Unicode stuff should be inserted here - -writeOutputF = moreF >==< mapF lines - -writeInputF = stringInputF - - diff --git a/src-3.0/GF/Fudgets/UnicodeF.hs b/src-3.0/GF/Fudgets/UnicodeF.hs deleted file mode 100644 index 024205698..000000000 --- a/src-3.0/GF/Fudgets/UnicodeF.hs +++ /dev/null @@ -1,37 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : UnicodeF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:17 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Fudgets.UnicodeF (fudlogueWriteU) where -import Fudgets - -import GF.Data.Operations -import GF.Text.Unicode - --- AR 12/4/2000, 18/9/2001 (added font parameter) - -fudlogueWriteU :: String -> (String -> String) -> IO () -fudlogueWriteU fn trans = - fudlogue $ - shellF "GF Unicode Output" (writeF fn trans >+< quitButtonF) - -writeF fn trans = writeOutputF fn >==< mapF trans >==< writeInputF fn - -displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) - -writeOutputF fn = moreF' (setFont fn) >==< justWriteOutputF - -justWriteOutputF = mapF (map (wrapLines 0) . filter (/=[]) . map mkUnicode . lines) - -writeInputF fn = stringInputF' (setShowString mkUnicode . setFont fn) - diff --git a/src-3.0/GF/GFCC/ComposOp.hs b/src-3.0/GF/GFCC/ComposOp.hs deleted file mode 100644 index de2522bc7..000000000 --- a/src-3.0/GF/GFCC/ComposOp.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -module GF.GFCC.ComposOp (Compos(..),composOp,composOpM,composOpM_,composOpMonoid, - composOpMPlus,composOpFold) where - -import Control.Monad.Identity -import Data.Monoid - -class Compos t where - compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) - -> (forall a. t a -> m (t a)) -> t c -> m (t c) - -composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c -composOp f = runIdentity . composOpM (Identity . f) - -composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c) -composOpM = compos return ap - -composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m () -composOpM_ = composOpFold (return ()) (>>) - -composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m -composOpMonoid = composOpFold mempty mappend - -composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b -composOpMPlus = composOpFold mzero mplus - -composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b -composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) - -newtype C b a = C { unC :: b } diff --git a/src-3.0/GF/GFCC/LexGFCC.hs b/src-3.0/GF/GFCC/LexGFCC.hs deleted file mode 100644 index c86195e3d..000000000 --- a/src-3.0/GF/GFCC/LexGFCC.hs +++ /dev/null @@ -1,349 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "GF/GFCC/LexGFCC.x" #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.GFCC.LexGFCC where - - - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#else -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xcb\xff\xff\xff\xeb\xff\xff\xff\x0b\x00\x00\x00\x9a\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\xb8\x01\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\xff\xff\x03\x00\x03\x00\x06\x00\xff\xff\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x04\x00\xff\xff\x03\x00\xff\xff\x07\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x05\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x07\x00\x0a\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0b\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7c\x00\x5d\x00\x3e\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[],[],[]] -{-# LINE 33 "GF/GFCC/LexGFCC.x" #-} - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words and symbols - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - | T_CId !String - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - PT _ (T_CId s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "lin" (b "flags" (b "cat" (b "abstract" N N) (b "concrete" N N)) (b "grammar" (b "fun" N N) N)) (b "param" (b "lindef" (b "lincat" N N) (b "oper" N N)) (b "printname" (b "pre" N N) N)) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> [Err pos] - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c - -alex_action_1 = tok (\p s -> PT p (TS $ share s)) -alex_action_2 = tok (\p s -> PT p (eitherResIdent (T_CId . share) s)) -alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_4 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) -alex_action_5 = tok (\p s -> PT p (TI $ share s)) -alex_action_6 = tok (\p s -> PT p (TD $ share s)) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - - -{-# LINE 35 "GenericTemplate.hs" #-} - - - - - - - - - - - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - case s of - -1# -> (last_acc, input) - _ -> alex_scan_tkn' user orig_input len input s last_acc - -alex_scan_tkn' user orig_input len input s last_acc = - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src-3.0/GF/GFCC/SkelGFCC.hs b/src-3.0/GF/GFCC/SkelGFCC.hs deleted file mode 100644 index 6972fd3c3..000000000 --- a/src-3.0/GF/GFCC/SkelGFCC.hs +++ /dev/null @@ -1,109 +0,0 @@ -module GF.GFCC.SkelGFCC where - --- Haskell module generated by the BNF converter - -import GF.GFCC.AbsGFCC -import GF.Data.ErrM -type Result = Err String - -failure :: Show a => a -> Result -failure x = Bad $ "Undefined case: " ++ show x - -transCId :: CId -> Result -transCId x = case x of - CId str -> failure x - - -transGrammar :: Grammar -> Result -transGrammar x = case x of - Grm cid cids abstract concretes -> failure x - - -transAbstract :: Abstract -> Result -transAbstract x = case x of - Abs flags fundefs catdefs -> failure x - - -transConcrete :: Concrete -> Result -transConcrete x = case x of - Cnc cid flags lindefs0 lindefs1 lindefs2 lindefs3 lindefs -> failure x - - -transFlag :: Flag -> Result -transFlag x = case x of - Flg cid str -> failure x - - -transCatDef :: CatDef -> Result -transCatDef x = case x of - Cat cid hypos -> failure x - - -transFunDef :: FunDef -> Result -transFunDef x = case x of - Fun cid type' exp -> failure x - - -transLinDef :: LinDef -> Result -transLinDef x = case x of - Lin cid term -> failure x - - -transType :: Type -> Result -transType x = case x of - DTyp hypos cid exps -> failure x - - -transExp :: Exp -> Result -transExp x = case x of - DTr cids atom exps -> failure x - EEq equations -> failure x - - -transAtom :: Atom -> Result -transAtom x = case x of - AC cid -> failure x - AS str -> failure x - AI n -> failure x - AF d -> failure x - AM n -> failure x - AV cid -> failure x - - -transTerm :: Term -> Result -transTerm x = case x of - R terms -> failure x - P term0 term -> failure x - S terms -> failure x - K tokn -> failure x - V n -> failure x - C n -> failure x - F cid -> failure x - FV terms -> failure x - W str term -> failure x - TM -> failure x - RP term0 term -> failure x - - -transTokn :: Tokn -> Result -transTokn x = case x of - KS str -> failure x - KP strs variants -> failure x - - -transVariant :: Variant -> Result -transVariant x = case x of - Var strs0 strs -> failure x - - -transHypo :: Hypo -> Result -transHypo x = case x of - Hyp cid type' -> failure x - - -transEquation :: Equation -> Result -transEquation x = case x of - Equ exps exp -> failure x - - - diff --git a/src-3.0/GF/GFCC/TestGFCC.hs b/src-3.0/GF/GFCC/TestGFCC.hs deleted file mode 100644 index c379a687a..000000000 --- a/src-3.0/GF/GFCC/TestGFCC.hs +++ /dev/null @@ -1,58 +0,0 @@ --- automatically generated by BNF Converter -module Main where - - -import IO ( stdin, hGetContents ) -import System ( getArgs, getProgName ) - -import GF.GFCC.LexGFCC -import GF.GFCC.ParGFCC -import GF.GFCC.SkelGFCC -import GF.GFCC.PrintGFCC -import GF.GFCC.AbsGFCC - - - - -import GF.Data.ErrM - -type ParseFun a = [Token] -> Err a - -myLLexer = myLexer - -type Verbosity = Int - -putStrV :: Verbosity -> String -> IO () -putStrV v s = if v > 1 then putStrLn s else return () - -runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () -runFile v p f = putStrLn f >> readFile f >>= run v p - -run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () -run v p s = let ts = myLLexer s in case p ts of - Bad s -> do putStrLn "\nParse Failed...\n" - putStrV v "Tokens:" - putStrV v $ show ts - putStrLn s - Ok tree -> do putStrLn "\nParse Successful!" - showTree v tree - - - -showTree :: (Show a, Print a) => Int -> a -> IO () -showTree v tree - = do - putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree - putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree - -main :: IO () -main = do args <- getArgs - case args of - [] -> hGetContents stdin >>= run 2 pGrammar - "-s":fs -> mapM_ (runFile 0 pGrammar) fs - fs -> mapM_ (runFile 2 pGrammar) fs - - - - - diff --git a/src-3.0/GF/GFModes.hs b/src-3.0/GF/GFModes.hs deleted file mode 100644 index faab3cede..000000000 --- a/src-3.0/GF/GFModes.hs +++ /dev/null @@ -1,112 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Aarne Ranta --- Stability : (stability) --- Portability : (portability) --- --- > CVS $Date: 2005/10/06 10:02:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.GFModes (gfInteract, gfBatch, batchCompile) where - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Compile.ShellState -import GF.Shell.ShellCommands -import GF.Shell -import GF.Shell.CommandL (execCommandHistory) -import GF.Shell.SubShell -import GF.Shell.PShell -import GF.Shell.JGF -import Data.Char (isSpace) - --- separated from GF Main 24/6/2003 - -gfInteract :: HState -> IO HState -gfInteract st@(env,hist@(his,_,_,_)) = do - -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch. - (s,cs) <- getCommandLines st - case ifImpure cs of - - -- these are the three impure commands - Just (ICQuit,_) -> do - ifNotSilent "See you." - return st - Just (ICExecuteHistory file,_) -> do - ss <- readFileIf file - let co = pCommandLines st ss - st' <- execLinesH s co st - gfInteract st' - Just (ICEarlierCommand i,_) -> do - let line = earlierCommandH st i - co = pCommandLine st $ words line - st' <- execLinesH line [co] st -- s would not work in execLinesH - gfInteract st' - - Just (ICReload,_) -> case dropWhile (not . isImport) his of - line:_ -> do - let co = pCommandLine st $ words line - st' <- execLinesH line [co] st - gfInteract st' - _ -> do - putStrLn "No previous import" - gfInteract st - - Just (ICEditSession,os) -> case getOptVal os useFile of - Just file -> do - s <- readFileIf file - (env',tree) <- execCommandHistory env s - gfInteract st - _ -> - editSession (addOptions os opts) env >> gfInteract st - Just (ICTranslateSession,os) -> - translateSession (addOptions os opts) env >> gfInteract st - - -- this is a normal command sequence - _ -> do - st' <- execLinesH s cs st - gfInteract st' - where - opts = globalOptions env - ifNotSilent c = - if oElem beSilent opts then return () else putStrLnFlush c - isImport l = case words l of - "i":_ -> True - "import":_ -> True - _ -> False - -gfBatch :: HState -> IO HState -gfBatch st@(sh,_) = do - (s,cs) <- getCommandLinesBatch st - if s == "q" then return st else do - st' <- if all isSpace s then return st else do - putVe "" - putVe s - putVe "" - putVe "" - (_,st') <- execLines True cs st - putVe "" - return st' - gfBatch st' - where - putVe = putVerb st - -putVerb st@(sh,_) s = if (oElem beSilent (globalOptions sh)) - then return () - else putStrLnFlush s - -batchCompile :: Options -> FilePath -> IO () -batchCompile os file = do - let file' = mkGFC file - let st = initHState $ addGlobalOptions (options [iOpt "make"]) emptyShellState - let s = "i -o" +++ (unwords $ map ('-':) $ words $ prOpts os) +++ file - let cs = pCommandLines st s - execLines True cs st - return () - -mkGFC = reverse . ("cfg" ++) . dropWhile (/='.') . reverse diff --git a/src-3.0/GF/Grammar/AbsCompute.hs b/src-3.0/GF/Grammar/AbsCompute.hs deleted file mode 100644 index 57e21f1dd..000000000 --- a/src-3.0/GF/Grammar/AbsCompute.hs +++ /dev/null @@ -1,145 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AbsCompute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- computation in abstract syntax w.r.t. explicit definitions. --- --- old GF computation; to be updated ------------------------------------------------------------------------------ - -module GF.Grammar.AbsCompute (LookDef, - compute, - computeAbsTerm, - computeAbsTermIn, - beta - ) where - -import GF.Data.Operations - -import GF.Grammar.Abstract -import GF.Grammar.PrGrammar -import GF.Grammar.LookAbs -import GF.Grammar.Compute - -import Debug.Trace -import Data.List(intersperse) -import Control.Monad (liftM, liftM2) - --- for debugging -tracd m t = t --- tracd = trace - -compute :: GFCGrammar -> Exp -> Err Exp -compute = computeAbsTerm - -computeAbsTerm :: GFCGrammar -> Exp -> Err Exp -computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] - --- | a hack to make compute work on source grammar as well -type LookDef = Ident -> Ident -> Err (Maybe Term) - -computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp -computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where - compt vv t = case t of --- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) --- Abs x b -> liftM (Abs x) (compt (x:vv) b) - _ -> do - let t' = beta vv t - (yy,f,aa) <- termForm t' - let vv' = yy ++ vv - aa' <- mapM (compt vv') aa - case look f of - Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $ - case findMatch eqs aa' of - Ok (d,g) -> do - --- let (xs,ts) = unzip g - --- ts' <- alphaFreshAll vv' ts - let g' = g --- zip xs ts' - d' <- compt vv' $ substTerm vv' g' d - tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' - _ -> tracd ("no match" +++ prt t') $ - do - let v = mkApp f aa' - return $ mkAbs yy $ v - Just d -> tracd ("define" +++ prt t') $ do - da <- compt vv' $ mkApp d aa' - return $ mkAbs yy $ da - _ -> do - let t2 = mkAbs yy $ mkApp f aa' - tracd ("not defined" +++ prt_ t2) $ return t2 - - look t = case t of - (Q m f) -> case lookd m f of - Ok (Just EData) -> Nothing -- canonical --- should always be QC - Ok md -> md - _ -> Nothing - Eqs _ -> return t ---- for nested fn - _ -> Nothing - -beta :: [Ident] -> Exp -> Exp -beta vv c = case c of - Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) - App f a -> - let (a',f') = (beta vv a, beta vv f) in - case f' of - Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) - _ -> (if a'==a && f'==f then id else beta vv) $ App f' a' - Prod x a b -> Prod x (beta vv a) (beta (x:vv) b) - Abs x b -> Abs x (beta (x:vv) b) - _ -> c - --- special version of pattern matching, to deal with comp under lambda - -findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) -findMatch cases terms = case cases of - [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) - (patts,_):_ | length patts /= length terms -> - Bad ("wrong number of args for patterns :" +++ - unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs) - _ -> findMatch cc terms - -tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do - t' <- termForm t - trym p t' - where - - trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- - case (p,t') of - (PV IW, _) | notMeta t -> return [] -- optimization with wildcard - (PV x, _) | notMeta t -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PP q p pp, ([], QC r f, tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PP q p pp, ([], Q r f, tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PT _ p',_) -> trym p' t' - (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t) - - notMeta e = case e of - Meta _ -> False - App f a -> notMeta f && notMeta a - Abs _ b -> notMeta b - _ -> True - - prtm p g = - prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g] diff --git a/src-3.0/GF/Grammar/Compute.hs b/src-3.0/GF/Grammar/Compute.hs deleted file mode 100644 index c76058cc2..000000000 --- a/src-3.0/GF/Grammar/Compute.hs +++ /dev/null @@ -1,426 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Grammar.Compute (computeConcrete, computeTerm,computeConcreteRec) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Str -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel) ---- - -import GF.Grammar.AppPredefined - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) - --- | computation of concrete syntax terms into normal form --- used mainly for partial evaluation -computeConcrete :: SourceGrammar -> Term -> Err Term -computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t -computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t - -computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term -computeTerm = computeTermOpt False - --- rec=True is used if it cannot be assumed that looked-up constants --- have already been computed (mainly with -optimize=noexpand in .gfr) - -computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term -computeTermOpt rec gr = comput True where - - comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging - case t of - - Q (IC "Predef") _ -> return t - Q p c -> look p c - - -- if computed do nothing - Computed t' -> return $ unComputed t' - - Vr x -> do - t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g - case t' of - _ | t == t' -> return t - _ -> comp g t' - - -- Abs x@(IA _) b -> do - Abs x b | full -> do - let (xs,b1) = termFormCnc t - b' <- comp ([(x,Vr x) | x <- xs] ++ g) b1 - return $ mkAbs xs b' - -- b' <- comp (ext x (Vr x) g) b - -- return $ Abs x b' - Abs _ _ -> return t -- hnf - - Let (x,(_,a)) b -> do - a' <- comp g a - comp (ext x a' g) b - - Prod x a b -> do - a' <- comp g a - b' <- comp (ext x (Vr x) g) b - return $ Prod x a' b' - - -- beta-convert - App f a -> case appForm t of - (h,as) | length as > 1 -> do - h' <- hnf g h - as' <- mapM (comp g) as - case h' of - _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as') - c@(QC _ _) -> do - return $ mkApp c as' - Q (IC "Predef") f -> do - (t',b) <- appPredefined (mkApp h' as') - if b then return t' else comp g t' - - Abs _ _ -> do - let (xs,b) = termFormCnc h' - let g' = (zip xs as') ++ g - let as2 = drop (length xs) as' - let xs2 = drop (length as') xs - b' <- comp g' (mkAbs xs2 b) - if null as2 then return b' else comp g (mkApp b' as2) - - _ -> compApp g (mkApp h' as') - _ -> compApp g t - - P t l | isLockLabel l -> return $ R [] - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field - - - P t l -> do - t' <- comp g t - case t' of - FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants - R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ - lookup l $ reverse r - - ExtR a (R b) -> - case comp g (P (R b) l) of - Ok v -> return v - _ -> comp g (P a l) - ---- { - --- this is incorrect, since b can contain the proper value - ExtR (R a) b -> -- NOT POSSIBLE both a and b records! - case comp g (P (R a) l) of - Ok v -> return v - _ -> comp g (P b l) ---- - } --- - - Alias _ _ r -> comp g (P r l) - - S (T i cs) e -> prawitz g i (flip P l) cs e - S (V i cs) e -> prawitzV g i (flip P l) cs e - - _ -> returnC $ P t' l - - PI t l i -> comp g $ P t l ----- - - S t@(T ti cc) v -> do - v' <- comp g v - case v' of - FV vs -> do - ts' <- mapM (comp g . S t) vs - return $ variants ts' - _ -> case ti of -{- - TComp _ -> do - case term2patt v' of - Ok p' -> case lookup p' cc of - Just u -> comp g u - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - _ -> do - t' <- comp g t - return $ S t' v' --} - _ -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t - _ -> do - t' <- comp g t - return $ S t' v' -- if v' is not canonical - - - S t v -> do - - t' <- case t of --- T _ _ -> return t --- V _ _ -> return t - _ -> comp g t - - v' <- comp g v - - case v' of - FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants - _ -> case t' of - FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants - - T _ [(PV IW,c)] -> comp g c --- an optimization - T _ [(PT _ (PV IW),c)] -> comp g c - - T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization - T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c - - -- course-of-values table: look up by index, no pattern matching needed - V ptyp ts -> do - vs <- allParamValues gr ptyp - case lookup v' (zip vs [0 .. length vs - 1]) of - Just i -> comp g $ ts !! i ------ _ -> prtBad "selection" $ S t' v' -- debug - _ -> return $ S t' v' -- if v' is not canonical - - T (TComp _) cs -> do - case term2patt v' of - Ok p' -> case lookup p' cs of - Just u -> comp g u - _ -> return $ S t' v' -- if v' is not canonical - _ -> return $ S t' v' - - T _ cc -> case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t - _ -> return $ S t' v' -- if v' is not canonical - - Alias _ _ d -> comp g (S d v') - - S (T i cs) e -> prawitz g i (flip S v') cs e - S (V i cs) e -> prawitzV g i (flip S v') cs e - _ -> returnC $ S t' v' - - -- normalize away empty tokens - K "" -> return Empty - - -- glue if you can - Glue x0 y0 -> do - x <- comp g x0 - y <- comp g y0 - case (x,y) of - (FV ks,_) -> do - kys <- mapM (comp g . flip Glue y) ks - return $ variants kys - (_,FV ks) -> do - xks <- mapM (comp g . Glue x) ks - return $ variants xks - - (Alias _ _ d, y) -> comp g $ Glue d y - (x, Alias _ _ d) -> comp g $ Glue x d - - (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e - (s, S (T i cs) e) -> prawitz g i (Glue s) cs e - (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e - (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e - (_,Empty) -> return x - (Empty,_) -> return y - (K a, K b) -> return $ K (a ++ b) - (_, Alts (d,vs)) -> do ----- (K a, Alts (d,vs)) -> do - let glx = Glue x - comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) - (Alts _, ka) -> checks [do - y' <- strsFromTerm ka ----- (Alts _, K a) -> checks [do - x' <- strsFromTerm x -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] ----- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] - ,return $ Glue x y - ] - (C u v,_) -> comp g $ C u (Glue v y) - - _ -> do - mapM_ checkNoArgVars [x,y] - r <- composOp (comp g) t - returnC r - - Alts _ -> do - r <- composOp (comp g) t - returnC r - - -- remove empty - C a b -> do - a' <- comp g a - b' <- comp g b - case (a',b') of - (Alts _, K a) -> checks [do - as <- strsFromTerm a' -- this may fail when compiling opers - return $ variants [ - foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] - , - return $ C a' b' - ] - (Empty,_) -> returnC b' - (_,Empty) -> returnC a' - _ -> returnC $ C a' b' - - -- reduce free variation as much as you can - FV ts -> mapM (comp g) ts >>= returnC . variants - - -- merge record extensions if you can - ExtR r s -> do - r' <- comp g r - s' <- comp g s - case (r',s') of - (Alias _ _ d, _) -> comp g $ ExtR d s' - (_, Alias _ _ d) -> comp g $ Glue r' d - - (R rs, R ss) -> plusRecord r' s' - (RecType rs, RecType ss) -> plusRecType r' s' - _ -> return $ ExtR r' s' - - -- case-expand tables - -- if already expanded, don't expand again - T i@(TComp ty) cs -> do - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapPairsM (comp g) cs ----- return $ V ty (map snd cs') - return $ T i cs' - --- this means some extra work; should implement TSh directly - TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] - - T i cs -> do - pty0 <- getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs -> do - - cs' <- mapM (compBranchOpt g) cs - sts <- mapM (matchPattern cs') vs - ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts - ps <- mapM term2patt vs - let ps' = ps --- PT ptyp (head ps) : tail ps ----- return $ V ptyp ts -- to save space, just course of values - return $ T (TComp ptyp) (zip ps' ts) - _ -> do - cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - - Alias c a d -> do - d' <- comp g d - return $ Alias c a d' -- alias only disappears in certain redexes - - -- otherwise go ahead - _ -> composOp (comp g) t >>= returnC - - where - - compApp g (App f a) = do - f' <- hnf g f - a' <- comp g a - case (f',a') of - (Abs x b, FV as) -> - mapM (\c -> comp (ext x c g) b) as >>= return . variants - (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants - (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants - (Abs x b,_) -> comp (ext x a' g) b - - (QC _ _,_) -> returnC $ App f' a' - - (Alias _ _ d, _) -> comp g (App d a') - - (S (T i cs) e,_) -> prawitz g i (flip App a') cs e - (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e - - _ -> do - (t',b) <- appPredefined (App f' a') - if b then return t' else comp g t' - - hnf = comput False - comp = comput True - - look p c - | rec = lookupResDef gr p c >>= comp [] - | otherwise = lookupResDef gr p c - -{- - look p c = case lookupResDefKind gr p c of - Ok (t,_) | noExpand p || rec -> comp [] t - Ok (t,_) -> return t - Bad s -> raise s - - noExpand p = errVal False $ do - mo <- lookupModMod gr p - return $ case getOptVal (iOpts (flags mo)) useOptimizer of - Just "noexpand" -> True - _ -> False --} - - ext x a g = (x,a):g - - returnC = return --- . computed - - variants ts = case nub ts of - [t] -> t - ts -> FV ts - - isCan v = case v of - Con _ -> True - QC _ _ -> True - App f a -> isCan f && isCan a - R rs -> all (isCan . snd . snd) rs - _ -> False - - compBranch g (p,v) = do - let g' = contP p ++ g - v' <- comp g' v - return (p,v') - - compBranchOpt g c@(p,v) = case contP p of - [] -> return c - _ -> err (const (return c)) return $ compBranch g c - - contP p = case p of - PV x -> [(x,Vr x)] - PC _ ps -> concatMap contP ps - PP _ _ ps -> concatMap contP ps - PT _ p -> contP p - PR rs -> concatMap (contP . snd) rs - - PAs x p -> (x,Vr x) : contP p - - PSeq p q -> concatMap contP [p,q] - PAlt p q -> concatMap contP [p,q] - PRep p -> contP p - PNeg p -> contP p - - _ -> [] - - prawitz g i f cs e = do - cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] - return $ S (T i cs') e - prawitzV g i f cs e = do - cs' <- mapM (comp g) [(f v) | v <- cs] - return $ S (V i cs') e - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Err Term -checkNoArgVars t = case t of - Vr (IA _) -> Bad $ glueErrorMsg $ prt t - Vr (IAV _) -> Bad $ glueErrorMsg $ prt t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ - "Use Prelude.bind instead." diff --git a/src-3.0/GF/Grammar/LookAbs.hs b/src-3.0/GF/Grammar/LookAbs.hs index 665c6b0b7..f9a251eb1 100644 --- a/src-3.0/GF/Grammar/LookAbs.hs +++ b/src-3.0/GF/Grammar/LookAbs.hs @@ -12,28 +12,12 @@ -- (Description of the module) ----------------------------------------------------------------------------- -module GF.Grammar.LookAbs (GFCGrammar, - lookupAbsDef, +module GF.Grammar.LookAbs ( lookupFunType, - lookupCatContext, - lookupTransfer, - isPrimitiveFun, - lookupRef, - refsForType, - funRulesOf, - hasHOAS, - allCatsOf, - allBindCatsOf, - funsForType, - funsOnType, - funsOnTypeFs, - allDefs, - lookupFunTypeSrc, - lookupCatContextSrc + lookupCatContext ) where import GF.Data.Operations -import qualified GF.Canon.GFC as C import GF.Grammar.Abstract import GF.Infra.Ident @@ -42,155 +26,28 @@ import GF.Infra.Modules import Data.List (nub) import Control.Monad -type GFCGrammar = C.CanonGrammar - -lookupAbsDef :: GFCGrammar -> Ident -> Ident -> Err (Maybe Term) -lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - C.AbsFun _ t -> return $ return t - C.AnyInd _ n -> lookupAbsDef gr n c - _ -> return Nothing - _ -> Bad $ prt m +++ "is not an abstract module" - -lookupFunType :: GFCGrammar -> Ident -> Ident -> Err Type -lookupFunType gr m c = errIn ("looking up funtype of" +++ prt c +++ "in module" +++ prt m) $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - C.AbsFun t _ -> return t - C.AnyInd _ n -> lookupFunType gr n c - _ -> prtBad "cannot find type of" c - _ -> Bad $ prt m +++ "is not an abstract module" - -lookupCatContext :: GFCGrammar -> Ident -> Ident -> Err Context -lookupCatContext gr m c = errIn ("looking up context of cat" +++ prt c) $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - C.AbsCat co _ -> return co - C.AnyInd _ n -> lookupCatContext gr n c - _ -> prtBad "unknown category" c - _ -> Bad $ prt m +++ "is not an abstract module" - --- | lookup for transfer function: transfer-module-name, category name -lookupTransfer :: GFCGrammar -> Ident -> Ident -> Err Term -lookupTransfer gr m c = errIn ("looking up transfer of cat" +++ prt c) $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - C.AbsTrans t -> return t - C.AnyInd _ n -> lookupTransfer gr n c - _ -> prtBad "cannot transfer function for" c - _ -> Bad $ prt m +++ "is not a transfer module" - - --- | should be revised (20\/9\/2003) -isPrimitiveFun :: GFCGrammar -> Fun -> Bool -isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of - Ok (Just (Eqs [])) -> True -- is canonical - Ok (Just _) -> False -- has defining clauses - _ -> True -- has no definition - - --- | looking up refinement terms -lookupRef :: GFCGrammar -> Binds -> Term -> Err Val -lookupRef gr binds at = case at of - Q m f -> lookupFunType gr m f >>= return . vClos - Vr i -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds - EInt _ -> return valAbsInt - EFloat _ -> return valAbsFloat - K _ -> return valAbsString - _ -> prtBad "cannot refine with complex term" at --- - -refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,(Val,Bool))] -refsForType compat gr binds val = - -- bound variables --- never recursive? - [(Vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++ - -- integer and string literals - [(EInt i, (val,False)) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++ - [(EFloat i, (val,False)) | val == valAbsFloat, i <- [3.1415926]] ++ - [(K s, (val,False)) | val == valAbsString, s <- ["foo", "NN", "x"]] ++ - -- functions defined in the current abstract syntax - [(qq f, (vClos t,isRecursiveType t)) | (f,t) <- funsForType compat gr val] - - -funRulesOf :: GFCGrammar -> [(Fun,Type)] -funRulesOf gr = ----- funRulesForLiterals ++ - [((i,f),typ) | (i, ModMod m) <- modules gr, - mtype m == MTAbstract, - (f, C.AbsFun typ _) <- tree2list (jments m)] - --- testing for higher-order abstract syntax -hasHOAS :: GFCGrammar -> Bool -hasHOAS gr = any isHigherOrderType [t | (_,t) <- funRulesOf gr] where - -allCatsOf :: GFCGrammar -> [(Cat,Context)] -allCatsOf gr = - [((i,c),cont) | (i, ModMod m) <- modules gr, - isModAbs m, - (c, C.AbsCat cont _) <- tree2list (jments m)] - -allBindCatsOf :: GFCGrammar -> [Cat] -allBindCatsOf gr = - nub [c | (i, ModMod m) <- modules gr, - isModAbs m, - (c, C.AbsFun typ _) <- tree2list (jments m), - Ok (cont,_) <- [firstTypeForm typ], - c <- concatMap fst $ errVal [] $ mapM (catSkeleton . snd) cont - ] - -funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)] -funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr, - compat val typ] - -funsOnType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [((Fun,Int),Type)] -funsOnType compat gr = funsOnTypeFs compat (funRulesOf gr) - -funsOnTypeFs :: (Val -> Type -> Bool) -> [(Fun,Type)] -> Val -> [((Fun,Int),Type)] -funsOnTypeFs compat fs val = [((fun,i),typ) | - (fun,typ) <- fs, - Ok (args,_,_) <- [typeForm typ], - (i,arg) <- zip [0..] (map snd args), - compat val arg] - -allDefs :: GFCGrammar -> [(Fun,Term)] -allDefs gr = [((i,c),d) | (i, ModMod m) <- modules gr, - isModAbs m, - (c, C.AbsFun _ d) <- tree2list (jments m)] - -- | this is needed at compile time -lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type -lookupFunTypeSrc gr m c = do +lookupFunType :: Grammar -> Ident -> Ident -> Err Type +lookupFunType gr m c = do mi <- lookupModule gr m case mi of ModMod mo -> do info <- lookupIdentInfo mo c case info of AbsFun (Yes t) _ -> return t - AnyInd _ n -> lookupFunTypeSrc gr n c + AnyInd _ n -> lookupFunType gr n c _ -> prtBad "cannot find type of" c _ -> Bad $ prt m +++ "is not an abstract module" -- | this is needed at compile time -lookupCatContextSrc :: Grammar -> Ident -> Ident -> Err Context -lookupCatContextSrc gr m c = do +lookupCatContext :: Grammar -> Ident -> Ident -> Err Context +lookupCatContext gr m c = do mi <- lookupModule gr m case mi of ModMod mo -> do info <- lookupIdentInfo mo c case info of AbsCat (Yes co) _ -> return co - AnyInd _ n -> lookupCatContextSrc gr n c + AnyInd _ n -> lookupCatContext gr n c _ -> prtBad "unknown category" c _ -> Bad $ prt m +++ "is not an abstract module" diff --git a/src-3.0/GF/Grammar/PrGrammar.hs b/src-3.0/GF/Grammar/PrGrammar.hs index c3a21d1d6..186792eda 100644 --- a/src-3.0/GF/Grammar/PrGrammar.hs +++ b/src-3.0/GF/Grammar/PrGrammar.hs @@ -29,7 +29,7 @@ module GF.Grammar.PrGrammar (Print(..), tree2string, prprTree, prConstrs, prConstraints, prMetaSubst, prEnv, prMSubst, - prExp, prPatt, prOperSignature, + prExp, prOperSignature, lookupIdent, lookupIdentInfo ) where @@ -38,8 +38,6 @@ import GF.Data.Zipper import GF.Grammar.Grammar import GF.Infra.Modules import qualified GF.Source.PrintGF as P -import qualified GF.Canon.PrintGFC as C -import qualified GF.Canon.AbsGFC as A import GF.Grammar.Values import GF.Source.GrammarToSource --- import GFC (CanonGrammar) --- cycle of modules @@ -106,32 +104,6 @@ prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co] -- some GFC notions -instance Print A.Exp where prt = C.printTree -instance Print A.Term where prt = C.printTree -instance Print A.Case where prt = C.printTree -instance Print A.CType where prt = C.printTree -instance Print A.Label where prt = C.printTree -instance Print A.Module where prt = C.printTree -instance Print A.Def where prt = C.printTree -instance Print A.Canon where prt = C.printTree -instance Print A.Sort where prt = C.printTree - -instance Print A.Atom where - prt = C.printTree - prt_ (A.AC c) = prt_ c - prt_ (A.AD c) = prt_ c - prt_ a = prt a - -instance Print A.Patt where - prt = C.printTree - prt_ = prPatt - -instance Print A.CIdent where - prt = C.printTree - prt_ (A.CIQ _ c) = prt c - --- printing values and trees in editing - instance Print a => Print (Tr a) where prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees) prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t) @@ -252,15 +224,6 @@ prExp e = case e of App _ _ -> prParenth $ prExp e _ -> pr1 e -prPatt :: A.Patt -> String -prPatt p = case p of - A.PC c ps -> prt_ c +++ unwords (map pr1 ps) - _ -> prt p --- PR - where - pr1 p = case p of - A.PC _ (_:_) -> prParenth $ prPatt p - _ -> prPatt p - -- | option @-strip@ strips qualifications prTermOpt :: Options -> Term -> String prTermOpt opts = if oElem nostripQualif opts then prt else prExp diff --git a/src-3.0/GF/Grammar/SGrammar.hs b/src-3.0/GF/Grammar/SGrammar.hs deleted file mode 100644 index e0c001b6b..000000000 --- a/src-3.0/GF/Grammar/SGrammar.hs +++ /dev/null @@ -1,169 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- --- A simple format for context-free abstract syntax used e.g. in --- generation. AR 31\/3\/2006 --- --- (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.Grammar.SGrammar 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 -import GF.Infra.Ident (Ident) - -import GF.Data.Operations -import GF.Data.Zipper -import GF.Infra.Option - -import Data.List - --- (c) Aarne Ranta 2006 under GNU GPL - - -type SGrammar = BinTree SCat [SRule] -type SIdent = String -type SRule = (SFun,SType) -type SType = ([SCat],SCat) -type SCat = SIdent -type SFun = (Double,SIdent) - -allRules gr = concat [rs | (c,rs) <- tree2list gr] - -data STree = - SApp (SFun,[STree]) - | SMeta SCat - | SString String - | SInt Integer - | SFloat Double - deriving (Show,Eq) - -depth :: STree -> Int -depth t = case t of - SApp (_,ts@(_:_)) -> maximum (map depth ts) + 1 - _ -> 1 - -type Probs = BinTree Ident Double - -emptyProbs :: Probs -emptyProbs = emptyBinTree - -prProbs :: Probs -> String -prProbs = unlines . map pr . tree2list where - pr (f,p) = prt f ++ "\t" ++ show p - ------------------------------------------- --- translate grammar to simpler form and generated trees back - -gr2sgr :: Options -> Probs -> GFCGrammar -> SGrammar -gr2sgr opts probs gr = buildTree [(c,norm (noexp c rs)) | rs@((_,(_,c)):_) <- rules] where - noe = maybe [] (chunks ',') $ getOptVal opts (aOpt "noexpand") - only = maybe [] (chunks ',') $ getOptVal opts (aOpt "doexpand") - un = getOptInt opts (aOpt "atoms") - rules = - prune $ - groupBy (\x y -> scat x == scat y) $ - sortBy (\x y -> compare (scat x) (scat y)) $ - [(trId f, ty') | (f,ty) <- funRulesOf gr, ty' <- trTy ty] - trId (_,f) = let f' = prt f in case lookupTree prt f probs of - Ok p -> (p,f') - _ -> (2.0, f') - trTy ty = case catSkeleton ty of - Ok (mcs,mc) -> [(map trCat mcs, trCat mc)] - _ -> [] - trCat (m,c) = prt c --- - scat (_,(_,c)) = c - - prune rs = maybe rs (\n -> map (onlyAtoms n) rs) $ un - - norm = fillProb - - onlyAtoms n rs = - let (rs1,rs2) = partition atom rs - in take n rs1 ++ rs2 - atom = null . fst . snd - - noexp c rs - | null only = if elem c noe then [((2.0,'?':c),([],c))] else rs - | otherwise = if elem c only then rs else [((2.0,'?':c),([],c))] - --- for cases where explicit probability is not given (encoded as --- p > 1) divide the remaining mass by the number of such cases - -fillProb :: [SRule] -> [SRule] -fillProb rs = [((defa p,f),ty) | ((p,f),ty) <- rs] where - defa p = if p > 1.0 then def else p - def = (1 - sum given) / genericLength nope - (nope,given) = partition (> 1.0) [p | ((p,_),_) <- rs] - --- str2tr :: STree -> Exp -str2tr t = case t of - SApp ((_,'?':c),[]) -> mkMeta 0 -- from noexpand=c - SApp ((_,f),ts) -> mkApp (trId f) (map str2tr ts) - SMeta _ -> mkMeta 0 - SString s -> K s - SInt i -> EInt i - SFloat i -> EFloat i - where - trId = cn . zIdent - --- tr2str :: Tree -> STree -tr2str (Tr (N (_,at,val,_,_),ts)) = case (at,val) of - (AtC (_,f), _) -> SApp ((2.0,prt_ f),map tr2str ts) - (AtM _, v) -> SMeta (catOf v) - (AtL s, _) -> SString s - (AtI i, _) -> SInt i - (AtF i, _) -> SFloat i - _ -> SMeta "FAILED_TO_GENERATE" ---- err monad! - where - catOf v = case v of - VApp w _ -> catOf w - VCn (_,c) -> prt_ c - _ -> "FAILED_TO_GENERATE_FROM_META" - - ------------------------------------------- --- to test - -prSTree t = case t of - SApp ((_,f),ts) -> f ++ concat (map pr1 ts) - SMeta c -> '?':c - SString s -> prQuotedString s - SInt i -> show i - SFloat i -> show i - where - pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t) - pr1 t = prSTree t - -pSRule :: String -> SRule -pSRule s = case words s of - f : _ : cs -> ((2.0,f),(init cs', last cs')) - where cs' = [cs !! i | i <- [0,2..length cs - 1]] - _ -> error $ "not a rule" +++ s - -exSgr = map pSRule [ - "Pred : NP -> VP -> S" - ,"Compl : TV -> NP -> VP" - ,"PredVV : VV -> VP -> VP" - ,"DefCN : CN -> NP" - ,"ModCN : AP -> CN -> CN" - ,"john : NP" - ,"walk : VP" - ,"love : TV" - ,"try : VV" - ,"girl : CN" - ,"big : AP" - ] diff --git a/src-3.0/GF/Grammar/TC.hs b/src-3.0/GF/Grammar/TC.hs deleted file mode 100644 index be52d1889..000000000 --- a/src-3.0/GF/Grammar/TC.hs +++ /dev/null @@ -1,299 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.11 $ --- --- Thierry Coquand's type checking algorithm that creates a trace ------------------------------------------------------------------------------ - -module GF.Grammar.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkEqs, - eqVal, - whnf - ) where - -import GF.Data.Operations -import GF.Grammar.Abstract -import GF.Grammar.AbsCompute - -import Control.Monad -import Data.List (sortBy) - -data AExp = - AVr Ident Val - | ACn QIdent Val - | AType - | AInt Integer - | AFloat Double - | AStr String - | AMeta MetaSymb Val - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp - | AEqs [([Exp],AExp)] --- not used - | AData Val - deriving (Eq,Show) - -type Theory = QIdent -> Err Val - -lookupConst :: Theory -> QIdent -> Err Val -lookupConst th f = th f - -lookupVar :: Env -> Ident -> Err Val -lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g) --- wild card IW: no error produced, ?0 instead. - -type TCEnv = (Int,Env,Env) - -emptyTCEnv :: TCEnv -emptyTCEnv = (0,[],[]) - -whnf :: Val -> Err Val -whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug - case v of - VApp u w -> do - u' <- whnf u - w' <- whnf w - app u' w' - VClos env e -> eval env e - _ -> return v - -app :: Val -> Val -> Err Val -app u v = case u of - VClos env (Abs x e) -> eval ((x,v):env) e - _ -> return $ VApp u v - -eval :: Env -> Exp -> Err Val -eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ - case e of - Vr x -> lookupVar env x - Q m c -> return $ VCn (m,c) - QC m c -> return $ VCn (m,c) ---- == Q ? - Sort c -> return $ VType --- the only sort is Type - App f a -> join $ liftM2 app (eval env f) (eval env a) - _ -> return $ VClos env e - -eqVal :: Int -> Val -> Val -> Err [(Val,Val)] -eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ - do - w1 <- whnf u1 - w2 <- whnf u2 - let v = VGen k - case (w1,w2) of - (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) - (VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) -> - eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) - (VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) -> - liftM2 (++) - (eqVal k (VClos env1 a1) (VClos env2 a2)) - (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) - (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] - (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] - --- thus ignore qualifications; valid because inheritance cannot - --- be qualified. Simplifies annotation. AR 17/3/2005 - _ -> return [(w1,w2) | w1 /= w2] --- invariant: constraints are in whnf - -checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)]) -checkType th tenv e = checkExp th tenv e vType - -checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) -checkExp th tenv@(k,rho,gamma) e ty = do - typ <- whnf ty - let v = VGen k - case e of - Meta m -> return $ (AMeta m typ,[]) - EData -> return $ (AData typ,[]) - - Abs x t -> case typ of - VClos env (Prod y a b) -> do - a' <- whnf $ VClos env a --- - (t',cs) <- checkExp th - (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) - return (AAbs x a' t', cs) - _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ - --- {- --- to get deprec when checkEqs works (15/9/2005) - Eqs es -> do - bcs <- mapM (\b -> checkBranch th tenv b typ) es - let (bs,css) = unzip bcs - return (AEqs bs, concat css) --- - } - Prod x a b -> do - testErr (typ == vType) "expected Type" - (a',csa) <- checkType th tenv a - (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b - return (AProd x a' b', csa ++ csb) - - _ -> checkInferExp th tenv e typ - -checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) -checkInferExp th tenv@(k,_,_) e typ = do - (e',w,cs1) <- inferExp th tenv e - cs2 <- eqVal k w typ - return (e',cs1 ++ cs2) - -inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)]) -inferExp th tenv@(k,rho,gamma) e = case e of - Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x - Q m c - | m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) -> - return (ACn (m,c) vType, vType, []) - | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) - QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ---- - EInt i -> return (AInt i, valAbsInt, []) - EFloat i -> return (AFloat i, valAbsFloat, []) - K i -> return (AStr i, valAbsString, []) - Sort _ -> return (AType, vType, []) - App f t -> do - (f',w,csf) <- inferExp th tenv f - typ <- whnf w - case typ of - VClos env (Prod x a b) -> do - (a',csa) <- checkExp th tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) - _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ - _ -> prtBad "cannot infer type of expression" e - where - predefAbs c s = case c of - IC "Int" -> return $ const $ Q cPredefAbs cInt - IC "Float" -> return $ const $ Q cPredefAbs cFloat - IC "String" -> return $ const $ Q cPredefAbs cString - _ -> Bad s - -checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)] -checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of - Eqs es -> liftM concat $ mapM checkBranch es - _ -> liftM snd $ checkExp th tenv def val - where - checkBranch (ps,df) = - let - (ps',_,vars) = foldr p2t ([],0,[]) ps - fps = mkApp (Q m f) ps' - in errIn ("branch" +++ prt fps) $ do - (aexp, typ, cs1) <- inferExp th tenv fps - let - bds = binds vars aexp - tenv' = (k, rho, bds ++ gamma) - (_,cs2) <- errIn (show bds) $ checkExp th tenv' df typ - return $ (cs1 ++ cs2) - p2t p (ps,i,g) = case p of - PW -> (meta (MetaSymb i) : ps, i+1, g) - PV IW -> (meta (MetaSymb i) : ps, i+1, g) - PV x -> (meta (MetaSymb i) : ps, i+1,upd x i g) - PString s -> ( K s : ps, i, g) - PInt n -> (EInt n : ps, i, g) - PFloat n -> (EFloat n : ps, i, g) - PP m c xs -> (mkApp (qq (m,c)) xss : ps, i', g') - where (xss,i',g') = foldr p2t ([],i,g) xs - _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" - upd x i g = (x,i) : g --- to annotate pattern variables: treat as metas - - -- notice: in vars, the sequence 0.. is sorted. In subst aexp, all - -- this occurs and nothing else. - binds vars aexp = [(x,v) | ((x,_),v) <- zip vars metas] where - metas = map snd $ sortBy (\ (x,_) (y,_) -> compare x y) $ subst aexp - subst aexp = case aexp of - AMeta (MetaSymb i) v -> [(i,v)] - AApp c a _ -> subst c ++ subst a - _ -> [] -- never matter in patterns - -checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)]) -checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ - chB tenv' ps' ty - where - - (ps',_,rho2,k') = ps2ts k ps - tenv' = (k, rho2++rho, gamma) ---- k' ? - (k,rho,gamma) = tenv - - chB tenv@(k,rho,gamma) ps ty = case ps of - p:ps2 -> do - typ <- whnf ty - case typ of - VClos env (Prod y a b) -> do - a' <- whnf $ VClos env a - (p', sigma, binds, cs1) <- checkP tenv p y a' - let tenv' = (length binds, sigma ++ rho, binds ++ gamma) - ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) - return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt - _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ - [] -> do - (e,cs) <- checkExp th tenv t ty - return (([],e),cs) - checkP env@(k,rho,gamma) t x a = do - (delta,cs) <- checkPatt th env t a - let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] - return (VClos sigma t, sigma, delta, cs) - - ps2ts k = foldr p2t ([],0,[],k) - p2t p (ps,i,g,k) = case p of - PW -> (meta (MetaSymb i) : ps, i+1,g,k) - PV IW -> (meta (MetaSymb i) : ps, i+1,g,k) - PV x -> (vr x : ps, i, upd x k g,k+1) - PString s -> (K s : ps, i, g, k) - PInt n -> (EInt n : ps, i, g, k) - PFloat n -> (EFloat n : ps, i, g, k) - PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') - where (xss,j,g',k') = foldr p2t ([],i,g,k) xs - _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" - - upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables - - -checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)]) -checkPatt th tenv exp val = do - (aexp,_,cs) <- checkExpP tenv exp val - let binds = extrBinds aexp - return (binds,cs) - where - extrBinds aexp = case aexp of - AVr i v -> [(i,v)] - AApp f a _ -> extrBinds f ++ extrBinds a - _ -> [] -- no other cases are possible - ---- ad hoc, to find types of variables - checkExpP tenv@(k,rho,gamma) exp val = case exp of - Meta m -> return $ (AMeta m val, val, []) - Vr x -> return $ (AVr x val, val, []) - EInt i -> return (AInt i, valAbsInt, []) - EFloat i -> return (AFloat i, valAbsFloat, []) - K s -> return (AStr s, valAbsString, []) - - Q m c -> do - typ <- lookupConst th (m,c) - return $ (ACn (m,c) typ, typ, []) - QC m c -> do - typ <- lookupConst th (m,c) - return $ (ACn (m,c) typ, typ, []) ---- - App f t -> do - (f',w,csf) <- checkExpP tenv f val - typ <- whnf w - case typ of - VClos env (Prod x a b) -> do - (a',_,csa) <- checkExpP tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) - _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ - _ -> prtBad "cannot typecheck pattern" exp - --- auxiliaries - -noConstr :: Err Val -> Err (Val,[(Val,Val)]) -noConstr er = er >>= (\v -> return (v,[])) - -mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) -mkAnnot a ti = do - (v,cs) <- ti - return (a v, v, cs) - diff --git a/src-3.0/GF/Grammar/TypeCheck.hs b/src-3.0/GF/Grammar/TypeCheck.hs deleted file mode 100644 index 97b7ff243..000000000 --- a/src-3.0/GF/Grammar/TypeCheck.hs +++ /dev/null @@ -1,311 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TypeCheck --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/15 16:22:02 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.TypeCheck (-- * top-level type checking functions; TC should not be called directly. - annotate, annotateIn, - justTypeCheck, checkIfValidExp, - reduceConstraints, - splitConstraints, - possibleConstraints, - reduceConstraintsNode, - performMetaSubstNode, - -- * some top-level batch-mode checkers for the compiler - justTypeCheckSrc, - grammar2theorySrc, - checkContext, - checkTyp, - checkEquation, - checkConstrs, - editAsTermCommand, - exp2termCommand, - exp2termlistCommand, - tree2termlistCommand - ) where - -import GF.Data.Operations -import GF.Data.Zipper - -import GF.Grammar.Abstract -import GF.Grammar.AbsCompute -import GF.Grammar.Refresh -import GF.Grammar.LookAbs -import qualified GF.Grammar.Lookup as Lookup --- - -import GF.Grammar.TC - -import GF.Grammar.Unify --- - -import Control.Monad (foldM, liftM, liftM2) -import Data.List (nub) --- - --- top-level type checking functions; TC should not be called directly. - -annotate :: GFCGrammar -> Exp -> Err Tree -annotate gr exp = annotateIn gr [] exp Nothing - --- | type check in empty context, return a list of constraints -justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints -justTypeCheck gr e v = do - (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v - constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0 - return $ fst $ splitConstraints gr constrs1 - --- | type check in empty context, return the expression itself if valid -checkIfValidExp :: GFCGrammar -> Exp -> Err Exp -checkIfValidExp gr e = do - (_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e - constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0 - ifNull (return e) (Bad . unwords . prConstrs) constrs1 - -annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree -annotateIn gr gamma exp = maybe (infer exp) (check exp) where - infer e = do - (a,_,cs) <- inferExp theory env e - aexp2treeC (a,cs) - check e v = do - (a,cs) <- checkExp theory env e v - aexp2treeC (a,cs) - env = initTCEnv gamma - theory = grammar2theory gr - aexp2treeC (a,c) = do - c' <- reduceConstraints (lookupAbsDef gr) (length gamma) c - aexp2tree (a,c') - --- | invariant way of creating TCEnv from context -initTCEnv gamma = - (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) - --- | process constraints after eqVal by computing by defs -reduceConstraints :: LookDef -> Int -> Constraints -> Err Constraints -reduceConstraints look i = liftM concat . mapM redOne where - redOne (u,v) = do - u' <- computeVal look u - v' <- computeVal look v - eqVal i u' v' - -computeVal :: LookDef -> Val -> Err Val -computeVal look v = case v of - VClos g@(_:_) e -> do - e' <- compt (map fst g) e --- bindings of g in e? - whnf $ VClos g e' -{- ---- - _ -> do ---- how to compute a Val, really?? - e <- val2exp v - e' <- compt [] e - whnf $ vClos e' --} - VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf - _ -> whnf v - where - compt = computeAbsTermIn look - compv = computeVal look - --- | take apart constraints that have the form (? <> t), usable as solutions -splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst) -splitConstraints gr = splitConstraintsGen (lookupAbsDef gr) - -splitConstraintsSrc :: Grammar -> Constraints -> (Constraints,MetaSubst) -splitConstraintsSrc gr = splitConstraintsGen (Lookup.lookupAbsDef gr) - -splitConstraintsGen :: LookDef -> Constraints -> (Constraints,MetaSubst) -splitConstraintsGen look cs = csmsu where - - csmsu = (nub [(a,b) | (a,b) <- csf1,a /= b],msf1) - (csf1,msf1) = unif (csf,msf) -- alternative: filter first - (csf,msf) = foldr mkOne ([],[]) cs - - csmsf = foldr mkOne ([],msu) csu - (csu,msu) = unif (cs1,[]) -- alternative: unify first - - cs1 = errVal cs $ reduceConstraints look 0 cs - - mkOne (u,v) = case (u,v) of - (VClos g (Meta m), v) | null g -> sub m v - (v, VClos g (Meta m)) | null g -> sub m v - -- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG - c -> con c - con c (cs,ms) = (c:cs,ms) - sub m v (cs,ms) = (cs,(m,v):ms) - - unifo = id -- alternative: don't use unification - - unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification - (cs',ms') <- unifyVal cs - return (cs', ms' ++ ms) - -performMetaSubstNode :: MetaSubst -> TrNode -> TrNode -performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let - v' = metaSubstVal v - b' = [(x,metaSubstVal v) | (x,v) <- b] - c' = [(u',v') | (u,v) <- c, - let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v'] - in N (b',a,v',(c',m),s) - where - metaSubstVal u = errVal u $ whnf $ case u of - VApp f a -> VApp (metaSubstVal f) (metaSubstVal a) - VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e) - _ -> u - metaSubstExp e = case e of - Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst - _ -> composSafeOp metaSubstExp e - -reduceConstraintsNode :: GFCGrammar -> TrNode -> TrNode -reduceConstraintsNode gr = changeConstrs red where - red cs = errVal cs $ reduceConstraints (lookupAbsDef gr) 0 cs - --- | weak heuristic to narrow down menus; not used for TC. 15\/11\/2001. --- the age-old method from GF 0.9 -possibleConstraints :: GFCGrammar -> Constraints -> Bool -possibleConstraints gr = and . map (possibleConstraint gr) - -possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool -possibleConstraint gr (u,v) = errVal True $ do - u' <- val2exp u >>= compute gr - v' <- val2exp v >>= compute gr - return $ cts u' v' - where - cts t u = isUnknown t || isUnknown u || case (t,u) of - (Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d) - (QC m c, QC n d) -> c == d - (App f a, App g b) -> cts f g && cts a b - (Abs x b, Abs y c) -> cts b c - (Prod x a f, Prod y b g) -> cts a b && cts f g - (_ , _) -> False - - isUnknown t = case t of - Vr _ -> True - Meta _ -> True - _ -> False - - notCan = not . isPrimitiveFun gr - --- interface to TC type checker - -type2val :: Type -> Val -type2val = VClos [] - -aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree -aexp2tree (aexp,cs) = do - (bi,at,vt,ts) <- treeForm aexp - ts' <- mapM aexp2tree [(t,[]) | t <- ts] - return $ Tr (N (bi,at,vt,(cs,[]),False),ts') - where - treeForm a = case a of - AAbs x v b -> do - (bi, at, vt, args) <- treeForm b - v' <- whnf v ---- should not be needed... - return ((x,v') : bi, at, vt, args) - AApp c a v -> do - (_,at,_,args) <- treeForm c - v' <- whnf v ---- - return ([],at,v',args ++ [a]) - AVr x v -> do - v' <- whnf v ---- - return ([],AtV x,v',[]) - ACn c v -> do - v' <- whnf v ---- - return ([],AtC c,v',[]) - AInt i -> do - return ([],AtI i,valAbsInt,[]) - AFloat i -> do - return ([],AtF i,valAbsFloat,[]) - AStr s -> do - return ([],AtL s,valAbsString,[]) - AMeta m v -> do - v' <- whnf v ---- - return ([],AtM m,v',[]) - _ -> Bad "illegal tree" -- AProd - -grammar2theory :: GFCGrammar -> Theory -grammar2theory gr (m,f) = case lookupFunType gr m f of - Ok t -> return $ type2val t - Bad s -> case lookupCatContext gr m f of - Ok cont -> return $ cont2val cont - _ -> Bad s - -cont2exp :: Context -> Exp -cont2exp c = mkProd (c, eType, []) -- to check a context - -cont2val :: Context -> Val -cont2val = type2val . cont2exp - --- some top-level batch-mode checkers for the compiler - -justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints -justTypeCheckSrc gr e v = do - (_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v - return $ filter notJustMeta constrs0 ----- return $ fst $ splitConstraintsSrc gr constrs0 ----- this change was to force proper tc of abstract modules. ----- May not be quite right. AR 13/9/2005 - -notJustMeta (c,k) = case (c,k) of - (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False - _ -> True - -grammar2theorySrc :: Grammar -> Theory -grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of - Ok t -> return $ type2val t - Bad s -> case lookupCatContextSrc gr m f of - Ok cont -> return $ cont2val cont - _ -> Bad s - -checkContext :: Grammar -> Context -> [String] -checkContext st = checkTyp st . cont2exp - -checkTyp :: Grammar -> Type -> [String] -checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType - -checkEquation :: Grammar -> Fun -> Trm -> [String] -checkEquation gr (m,fun) def = err singleton id $ do - typ <- lookupFunTypeSrc gr m fun ----- cs <- checkEqs (grammar2theorySrc gr) (initTCEnv []) ((m,fun),def) (vClos typ) - cs <- justTypeCheckSrc gr def (vClos typ) - let cs1 = filter notJustMeta cs ----- filter (not . possibleConstraint gr) cs ---- - return $ ifNull [] (singleton . prConstraints) cs1 - -checkConstrs :: Grammar -> Cat -> [Ident] -> [String] -checkConstrs gr cat _ = [] ---- check constructors! - - - - - - -{- ---- -err singleton concat . mapM checkOne where - checkOne con = do - typ <- lookupFunType gr con - typ' <- computeAbsTerm gr typ - vcat <- valCat typ' - return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con] --} - -editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp] -editAsTermCommand gr c e = err (const []) singleton $ do - t <- annotate gr $ refreshMetas [] e - t' <- c $ tree2loc t - return $ tree2exp $ loc2tree t' - -exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree -exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do - let exp = tree2exp t - exp2 <- f exp - annotate gr exp2 - -exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree] -exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp - -tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree] -tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f diff --git a/src-3.0/GF/IDE/IDECommands.hs b/src-3.0/GF/IDE/IDECommands.hs deleted file mode 100644 index 56d392a71..000000000 --- a/src-3.0/GF/IDE/IDECommands.hs +++ /dev/null @@ -1,95 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : IDECommands --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.2 $ --- --- Commands usable in grammar-writing IDE. ------------------------------------------------------------------------------ - -module GF.IDE.IDECommands where - -import GF.Infra.Ident (Ident, identC) -import GF.Compile.ShellState -import qualified GF.Shell.ShellCommands as S -import qualified GF.Shell.Commands as E -import qualified GF.Shell.CommandL as PE -import GF.UseGrammar.Session -import GF.UseGrammar.Custom -import GF.Grammar.PrGrammar - -import GF.Infra.Option -import GF.Data.Operations -import GF.Infra.Modules -import GF.Infra.UseIO - -data IDEState = IDE { - ideShellState :: ShellState, - ideAbstract :: Maybe Ident, - ideConcretes :: [Ident], - ideCurrentCnc :: Maybe Ident, - ideCurrentLin :: Maybe Ident, -- lin or lincat - ideSState :: Maybe SState - } - -emptyIDEState :: ShellState -> IDEState -emptyIDEState shst = IDE shst Nothing [] Nothing Nothing Nothing - -data IDECommand = - IDEInit - | IDEAbstract Ident - | IDEConcrete Ident - | IDELin Ident - | IDEShell String -- S.Command - | IDEEdit String -- E.Command - | IDEQuit - | IDEVoid String -- the given command itself maybe - - -execIDECommand :: IDECommand -> IDEState -> IOE IDEState -execIDECommand c state = case c of - IDEInit -> - return $ emptyIDEState env - IDEAbstract a -> - return $ state {ideAbstract = Just a} ---- check a exists or import it - IDEConcrete a -> - return $ state {ideCurrentCnc = Just a} ---- check a exists or import it - IDELin a -> - return $ state {ideCurrentLin = Just a} ---- check a exists - IDEEdit s -> - execEdit s - IDEShell s -> - execShell s - IDEVoid s -> ioeErr $ fail s - _ -> ioeErr $ fail "command not implemented" - - where - env = ideShellState state - sstate = maybe initSState id $ ideSState state - - execShell s = execEdit $ "gf" +++ s - - execEdit s = ioeIO $ do - (env',sstate') <- E.execCommand env (PE.pCommand s) sstate - return $ state {ideShellState = env', ideSState = Just sstate'} - - putMsg = putStrLn ---- XML - -pCommands :: String -> [IDECommand] -pCommands = map pCommand . concatMap (chunks ";;" . words) . lines - -pCommand :: [String] -> IDECommand -pCommand ws = case ws of - "gf" : s -> IDEShell $ unwords s - "edit" : s -> IDEEdit $ unwords s - "abstract" : a : _ -> IDEAbstract $ identC a - "concrete" : a : _ -> IDEConcrete $ identC a - "lin" : a : _ -> IDELin $ identC a - "empty" : _ -> IDEInit - "quit" : _ -> IDEQuit - _ -> IDEVoid $ unwords ws diff --git a/src-3.0/GF/Infra/Comments.hs b/src-3.0/GF/Infra/Comments.hs deleted file mode 100644 index 0126db468..000000000 --- a/src-3.0/GF/Infra/Comments.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Comments --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:34 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- comment removal ------------------------------------------------------------------------------ - -module GF.Infra.Comments ( remComments - ) where - --- | comment removal : line tails prefixed by -- as well as chunks in @{- ... -}@ -remComments :: String -> String -remComments s = - case s of - '"':s2 -> '"':pass remComments s2 -- comment marks in quotes not removed! - '{':'-':cs -> readNested cs - '-':'-':cs -> readTail cs - c:cs -> c : remComments cs - [] -> [] - where - readNested t = - case t of - '"':s2 -> '"':pass readNested s2 - '-':'}':cs -> remComments cs - _:cs -> readNested cs - [] -> [] - readTail t = - case t of - '\n':cs -> '\n':remComments cs - _:cs -> readTail cs - [] -> [] - pass f t = - case t of - '"':s2 -> '"': f s2 - c:s2 -> c:pass f s2 - _ -> t diff --git a/src-3.0/GF/Infra/Print.hs b/src-3.0/GF/Infra/Print.hs deleted file mode 100644 index 17f2c2188..000000000 --- a/src-3.0/GF/Infra/Print.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Pretty-printing ------------------------------------------------------------------------------ - -module GF.Infra.Print - (module GF.Infra.PrintClass - ) where - --- haskell modules: -import Data.Char (toUpper) --- gf modules: - -import GF.Infra.PrintClass -import GF.Data.Operations (Err(..)) -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC -import GF.CF.CF -import GF.CF.CFIdent -import qualified GF.Canon.PrintGFC as P - ------------------------------------------------------------- - ----------------------------------------------------------------------- - -instance Print Ident where - prt = P.printTree - -instance Print Term where - prt (Arg arg) = prt arg - prt (con `Par` []) = prt con - prt (con `Par` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")" - prt (LI ident) = "$" ++ prt ident - prt (R record) = "{" ++ prtSep "; " record ++ "}" - prt (term `P` lbl) = prt term ++ "." ++ prt lbl - prt (T _ table) = "table{" ++ prtSep "; " table ++ "}" - prt (V _ terms) = "values{" ++ prtSep "; " terms ++ "}" - prt (term `S` sel) = "(" ++ prt term ++ " ! " ++ prt sel ++ ")" - prt (FV terms) = "variants{" ++ prtSep " | " terms ++ "}" - prt (term `C` term') = prt term ++ " " ++ prt term' - prt (EInt n) = prt n - prt (K tokn) = show (prt tokn) - prt (E) = show "" - -instance Print Patt where - prt (con `PC` []) = prt con - prt (con `PC` pats) = prt con ++ "(" ++ prtSep "," pats ++ ")" - prt (PV ident) = "$" ++ prt ident - prt (PW) = "_" - prt (PR record) = "{" ++ prtSep ";" record ++ "}" - -instance Print Label where - prt (L ident) = prt ident - prt (LV nr) = "$" ++ show nr - -instance Print Tokn where - prt (KS str) = str - prt tokn@(KP _ _) = show tokn - -instance Print ArgVar where - prt (A cat argNr) = prt cat ++ "#" ++ show argNr - -instance Print CIdent where - prt (CIQ _ ident) = prt ident - -instance Print Case where - prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term - -instance Print Assign where - prt (lbl `Ass` term) = prt lbl ++ "=" ++ prt term - -instance Print PattAssign where - prt (lbl `PAss` pat) = prt lbl ++ "=" ++ prt pat - -instance Print Atom where - prt (AC c) = prt c - prt (AD c) = "<" ++ prt c ++ ">" - prt (AV i) = "$" ++ prt i - prt (AM n) = "?" ++ show n - prt atom = show atom - -instance Print CType where - prt (RecType rtype) = "{" ++ prtSep "; " rtype ++ "}" - prt (Table ptype vtype) = "(" ++ prt ptype ++ " => " ++ prt vtype ++ ")" - prt (Cn cn) = prt cn - prt (TStr) = "Str" - -instance Print Labelling where - prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype - -instance Print CFItem where - prt (CFTerm regexp) = prt regexp - prt (CFNonterm cat) = prt cat - -instance Print RegExp where - prt (RegAlts words) = "("++prtSep "|" words ++ ")" - prt (RegSpec tok) = prt tok - -instance Print CFTok where - prt (TS str) = str - prt (TC (c:str)) = '(' : toUpper c : ')' : str - prt (TL str) = show str - prt (TI n) = "#" ++ show n - prt (TV x) = "$" ++ prt x - prt (TM n s) = "?" ++ show n ++ s - -instance Print CFCat where - prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl - -instance Print CFFun where - prt (CFFun fun) = prt (fst fun) - -instance Print Exp where - prt = P.printTree - -instance Print a => Print (Err a) where - prt (Ok a) = prt a - prt (Bad str) = str - diff --git a/src-3.0/GF/Infra/ReadFiles.hs b/src-3.0/GF/Infra/ReadFiles.hs deleted file mode 100644 index ce33ec23f..000000000 --- a/src-3.0/GF/Infra/ReadFiles.hs +++ /dev/null @@ -1,362 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReadFiles --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Decide what files to read as function of dependencies and time stamps. --- --- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 --- --- to find all files that have to be read, put them in dependency order, and --- decide which files need recompilation. Name @file.gf@ is returned for them, --- and @file.gfc@ or @file.gfr@ otherwise. ------------------------------------------------------------------------------ - -module GF.Infra.ReadFiles (-- * Heading 1 - getAllFiles,fixNewlines,ModName,getOptionsFromFile, - -- * Heading 2 - gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile - ) where - -import GF.System.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime) - -import GF.Infra.Option -import GF.Data.Operations -import GF.Infra.UseIO - -import System -import Data.Char -import Control.Monad -import Data.List -import System.Directory -import System.FilePath - -type ModName = String -type ModEnv = [(ModName,ModTime)] - -getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] -getAllFiles opts ps env file = do - - -- read module headers from all files recursively - ds0 <- getImports ps file - let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] - if oElem beVerbose opts - then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) - else return () - -- get a topological sorting of files: returns file names --- deletes paths - ds1 <- ioeErr $ either - return - (\ms -> Bad $ "circular modules" +++ - unwords (map show (head ms))) $ topoTest $ map fst ds - - -- associate each file name with its path --- more optimal: save paths in ds1 - let paths = [(f,p) | ((f,_),p) <- ds] - let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] - if oElem fromSource opts - then return [gfFile (p f) | (p,f) <- pds1] - else do - - - ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 - - let ds4 = needCompile opts (map fst ds0) ds2 - return ds4 - --- to decide whether to read gf or gfc, or if in env; returns full file path - -data CompStatus = - CSComp -- compile: read gf - | CSRead -- read gfc - | CSEnv -- gfc is in env - | CSEnvR -- also gfr is in env - | CSDont -- don't read at all - | CSRes -- read gfr - deriving (Eq,Show) - --- for gfc, we also return ModTime to cope with earlier compilation of libs - -selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> - IO (ModName,(InitPath,(CompStatus,Maybe ModTime))) - -selectFormat opts env (p,f) = do - let pf = p f - let mtenv = lookup f env -- Nothing if f is not in env - let rtenv = lookup (resModName f) env - let fromComp = oElem isCompiled opts -- i -gfc - mtgfc <- getModTime $ gfcFile pf - mtgf <- getModTime $ gfFile pf - let stat = case (rtenv,mtenv,mtgfc,mtgf) of --- (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) - (_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc) --- (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv) --- (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv) - (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> - case mtenv of --- Just tenv | laterModTime tenv tgfc -> (CSEnv,Just tenv) - _ -> (CSRead,Just tgfc) - - --- (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist - (_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist - _ -> (CSComp,Nothing) - return $ (f, (p,stat)) - -needCompile :: Options -> - [ModuleHeader] -> - [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath] -needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where - - deps = [(snd m,map fst ms) | (m,ms) <- headers] - typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers] - uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m] - stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0 - - allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where - add os = [m | o <- os, Just n <- [lookup o deps],m <- n] - - -- only treat reused, interface, or instantiation if needed - sfiles = sfiles0 ---- map relevant sfiles0 - relevant fp@(f,(p,(st,_))) = - let us = uses f - isUsed = not (null us) - in - if not (isUsed && all noComp us) then - fp else - if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource] - || - (isUsed && all isAux us)) then - (f,(p,(CSDont,Nothing))) else - fp - - isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd - noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst - - -- mark as to be compiled those whose gfc is earlier than a deeper gfc - sfiles1 = map compTimes sfiles - compTimes fp@(f,(p,(_, Just t))) = - if any (> t) [t' | Just fs <- [lookup f deps], - f0 <- fs, - Just (_,(_,Just t')) <- [lookup f0 sfiles]] - then (f,(p,(CSComp, Nothing))) - else fp - compTimes fp = fp - - -- start with the changed files themselves; returns [ModName] - changed = [f | (f,(_,(CSComp,_))) <- sfiles1] - - -- add other files that depend on some changed file; returns [ModName] - iter np = let new = [f | (f,fs) <- deps, - not (elem f np), any (flip elem np) fs] - in if null new then np else (iter (new ++ np)) - - -- for each module in the full list, compile if depends on what needs compile - -- returns [FullPath] - mark cs = [(f,(path,st)) | - (f,(path,(st0,_))) <- sfiles1, - let st = if (elem f cs) then CSComp else st0] - - - -- if a compilable file depends on a resource, read gfr instead of gfc/env - -- but don't read gfr if already in env (by CSEnvR) - -- Also read res if the option "retain" is present - -- Also, if a "with" file has to be compiled, read its mother file from source - - res cs = map mkRes cs where - mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of - t | (not (null [m | (m,(_,CSComp)) <- cs, - Just ms <- [lookup m allDeps], elem f ms]) - || oElem retainOpers opts) - -> if elem t [MTyResource,MTyIncResource] - then (f,(path,CSRes)) else - if t == MTyIncomplete - then (f,(path,CSComp)) else - x - _ -> x - mkRes x = x - - - - -- construct list of paths to read - paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]] - - mkName f p st = mk (p f) where - mk = case st of - CSComp -> gfFile - CSRead -> gfcFile - CSRes -> gfrFile - -isGFC :: FilePath -> Bool -isGFC = (== ".gfc") . takeExtensions - -gfcFile :: FilePath -> FilePath -gfcFile f = addExtension f "gfc" - -gfrFile :: FilePath -> FilePath -gfrFile f = addExtension f "gfr" - -gfFile :: FilePath -> FilePath -gfFile f = addExtension f "gf" - -resModName :: ModName -> ModName -resModName = ('#':) - --- to get imports without parsing the whole files - -getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)] -getImports ps = get [] where - get ds file0 = do - let name = dropExtension file0 ---- dropExtension file0 - (p,s) <- tryRead name - let ((typ,mname),imps) = importsOfFile s - let namebody = takeFileName name - ioeErr $ testErr (mname == namebody) $ - "module name" +++ mname +++ "differs from file name" +++ namebody - case imps of - _ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read - [] -> return $ (((typ,name),[]),p):ds - _ -> do - let files = map (gfFile . fst) imps - foldM get ((((typ,name),imps),p):ds) files - tryRead name = do - file <- do - let file_gf = gfFile name - b <- doesFileExistPath ps file_gf -- try gf file first - if b then return file_gf else do - let file_gfr = gfrFile name - bb <- doesFileExistPath ps file_gfr -- gfr file next - if bb then return file_gfr else do - return (gfcFile name) -- gfc next - - readFileIfPath ps $ file - - - --- internal module dep information - -data ModUse = - MUReuse - | MUInstance - | MUComplete - | MUOther - deriving (Eq,Show) - -data ModTyp = - MTyResource - | MTyIncomplete - | MTyIncResource -- interface, incomplete resource - | MTyOther - deriving (Eq,Show) - -type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) - -importsOfFile :: String -> ModuleHeader -importsOfFile = - getModuleHeader . -- analyse into mod header - filter (not . spec) . -- ignore keywords and special symbols - unqual . -- take away qualifiers - unrestr . -- take away union restrictions - takeWhile (not . term) . -- read until curly or semic - lexs . -- analyse into lexical tokens - unComm -- ignore comments before the headed line - where - term = flip elem ["{",";"] - spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"] - unqual ws = case ws of - "(":q:ws' -> unqual ws' - w:ws' -> w:unqual ws' - _ -> ws - unrestr ws = case ws of - "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws' - w:ws' -> w:unrestr ws' - _ -> ws - -getModuleHeader :: [String] -> ModuleHeader -- with, reuse -getModuleHeader ws = case ws of - "incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in - case ty of - MTyResource -> ((MTyIncResource,name),us) - _ -> ((MTyIncomplete,name),us) - "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in - ((MTyIncResource,name),us) - - "resource":name:ws2 -> case ws2 of - "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)]) - m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - ms -> ((MTyResource,name),[(n,MUOther) | n <- ms]) - - "instance":name:m:ws2 -> case ws2 of - "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)]) - n:"with":ms -> - ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms]) - ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms]) - - "concrete":name:a:ws2 -> case span (/= "with") ws2 of - - (es,_:ms) -> ((MTyOther,name), - [(m,MUOther) | m <- es] ++ - [(n,MUComplete) | n <- ms]) - --- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - (ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms]) - - _:name:ws2 -> case ws2 of - "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)]) - ---- m:n:"with":ms -> - ---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms]) - m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) - ms -> ((MTyOther,name),[(n,MUOther) | n <- ms]) - _ -> error "the file is empty" - -unComm s = case s of - '-':'-':cs -> unComm $ dropWhile (/='\n') cs - '{':'-':cs -> dpComm cs - c:cs -> c : unComm cs - _ -> s - -dpComm s = case s of - '-':'}':cs -> unComm cs - c:cs -> dpComm cs - _ -> s - -lexs s = x:xs where - (x,y) = head $ lex s - xs = if null y then [] else lexs y - --- | options can be passed to the compiler by comments in @--#@, in the main file -getOptionsFromFile :: FilePath -> IO Options -getOptionsFromFile file = do - s <- readFileIfStrict file - let ls = filter (isPrefixOf "--#") $ lines s - return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls - --- | check if old GF file -isOldFile :: FilePath -> IO Bool -isOldFile f = do - s <- readFileIfStrict f - let s' = unComm s - return $ not (null s') && old (head (words s')) - where - old = flip elem $ words - "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule" - - - --- | old GF tolerated newlines in quotes. No more supported! -fixNewlines :: String -> String -fixNewlines s = case s of - '"':cs -> '"':mk cs - c :cs -> c:fixNewlines cs - _ -> s - where - mk s = case s of - '\\':'"':cs -> '\\':'"': mk cs - '"' :cs -> '"' :fixNewlines cs - '\n' :cs -> '\\':'n': mk cs - c :cs -> c : mk cs - _ -> s - diff --git a/src-3.0/GF/Infra/UseIO.hs b/src-3.0/GF/Infra/UseIO.hs deleted file mode 100644 index 4125a0417..000000000 --- a/src-3.0/GF/Infra/UseIO.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------- --- | --- Module : UseIO --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.17 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.UseIO where - -import GF.Data.Operations -import GF.System.Arch (prCPU) -import GF.Infra.Option -import GF.Today (libdir) - -import System.Directory -import System.IO -import System.IO.Error -import System.Environment -import System.FilePath -import Control.Monad - -#ifdef mingw32_HOST_OS -import System.Win32.DLL -import Foreign.Ptr -#endif - - -putShow' :: Show a => (c -> a) -> c -> IO () -putShow' f = putStrLn . show . length . show . f - -putIfVerb :: Options -> String -> IO () -putIfVerb opts msg = - if oElem beVerbose opts - then putStrLn msg - else return () - -putIfVerbW :: Options -> String -> IO () -putIfVerbW opts msg = - if oElem beVerbose opts - then putStr (' ' : msg) - else return () - --- | obsolete with IOE monad -errIO :: a -> Err a -> IO a -errIO = errOptIO noOptions - -errOptIO :: Options -> a -> Err a -> IO a -errOptIO os e m = case m of - Ok x -> return x - Bad k -> do - putIfVerb os k - return e - -prOptCPU :: Options -> Integer -> IO Integer -prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU - -putCPU :: IO () -putCPU = do - prCPU 0 - return () - -putPoint :: Show a => Options -> String -> IO a -> IO a -putPoint = putPoint' id - -putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c -putPoint' f opts msg act = do - let sil x = if oElem beSilent opts then return () else x - ve x = if oElem beVerbose opts then x else return () - ve $ putStrLn msg - a <- act - ve $ putShow' f a - ve $ putCPU - return a - -readFileStrict :: String -> IO String -readFileStrict f = do - s <- readFile f - return $ seq (length s) () - return s - -readFileIf = readFileIfs readFile -readFileIfStrict = readFileIfs readFileStrict - -readFileIfs rf f = catch (rf f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return "" - -type FileName = String -type InitPath = String -type FullPath = String - -getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) -getFilePath ps file = do - getFilePathMsg ("file" +++ file +++ "not found\n") ps file - -getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath) -getFilePathMsg msg paths file = get paths where - get [] = putStrFlush msg >> return Nothing - get (p:ps) = do - let pfile = p file - exist <- doesFileExist pfile - if exist then return (Just pfile) else get ps ---- catch (readFileStrict pfile >> return (Just pfile)) (\_ -> get ps) - -readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String) -readFileIfPath paths file = do - mpfile <- ioeIO $ getFilePath paths file - case mpfile of - Just pfile -> do - s <- ioeIO $ readFileStrict pfile - return (dropFileName pfile,s) - _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") - -doesFileExistPath :: [FilePath] -> String -> IOE Bool -doesFileExistPath paths file = do - mpfile <- ioeIO $ getFilePathMsg "" paths file - return $ maybe False (const True) mpfile - -gfLibraryPath = "GF_LIB_PATH" - --- | environment variable for grammar search path -gfGrammarPathVar = "GF_GRAMMAR_PATH" - -getLibraryPath :: IO FilePath -getLibraryPath = - catch - (getEnv gfLibraryPath) -#ifdef mingw32_HOST_OS - (\_ -> do exepath <- getModuleFileName nullPtr - let (path,_) = splitFileName exepath - canonicalizePath (combine path "../lib")) -#else - (const (return libdir)) -#endif - --- | extends the search path with the --- 'gfLibraryPath' and 'gfGrammarPathVar' --- environment variables. Returns only existing paths. -extendPathEnv :: [FilePath] -> IO [FilePath] -extendPathEnv ps = do - b <- getLibraryPath -- e.g. GF_LIB_PATH - s <- catch (getEnv gfGrammarPathVar) (const (return "")) -- e.g. GF_GRAMMAR_PATH - let ss = ps ++ splitSearchPath s - liftM concat $ mapM allSubdirs $ ss ++ [b s | s <- ss ++ ["prelude"]] - where - allSubdirs :: FilePath -> IO [FilePath] - allSubdirs [] = return [[]] - allSubdirs p = case last p of - '*' -> do let path = init p - fs <- getSubdirs path - return [path f | f <- fs] - _ -> do exists <- doesDirectoryExist p - if exists - then return [p] - else return [] - -getSubdirs :: FilePath -> IO [FilePath] -getSubdirs dir = do - fs <- catch (getDirectoryContents dir) (const $ return []) - foldM (\fs f -> do let fpath = dir f - p <- getPermissions fpath - if searchable p && not (take 1 f==".") - then return (fpath:fs) - else return fs ) [] fs - -justModuleName :: FilePath -> String -justModuleName = dropExtension . takeFileName - -splitInModuleSearchPath :: String -> [FilePath] -splitInModuleSearchPath s = case break isPathSep s of - (f,_:cs) -> f : splitInModuleSearchPath cs - (f,_) -> [f] - where - isPathSep :: Char -> Bool - isPathSep c = c == ':' || c == ';' - --- - -getLineWell :: IO String -> IO String -getLineWell ios = - catch getLine (\e -> if (isEOFError e) then ios else ioError e) - -putStrFlush :: String -> IO () -putStrFlush s = putStr s >> hFlush stdout - -putStrLnFlush :: String -> IO () -putStrLnFlush s = putStrLn s >> hFlush stdout - --- * a generic quiz session - -type QuestionsAndAnswers = [(String, String -> (Integer,String))] - -teachDialogue :: QuestionsAndAnswers -> String -> IO () -teachDialogue qas welc = do - putStrLn $ welc ++++ genericTeachWelcome - teach (0,0) qas - where - teach _ [] = do putStrLn "Sorry, ran out of problems" - teach (score,total) ((question,grade):quas) = do - putStr ("\n" ++ question ++ "\n> ") - answer <- getLine - if (answer == ".") then return () else do - let (result, feedback) = grade answer - score' = score + result - total' = total + 1 - putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total') - if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75) - then do putStrLn "\nCongratulations - you passed!" - else teach (score',total') quas - - genericTeachWelcome = - "The quiz is over when you have done at least 10 examples" ++++ - "with at least 75 % success." +++++ - "You can interrupt the quiz by entering a line consisting of a dot ('.').\n" - - --- * IO monad with error; adapted from state monad - -newtype IOE a = IOE (IO (Err a)) - -appIOE :: IOE a -> IO (Err a) -appIOE (IOE iea) = iea - -ioe :: IO (Err a) -> IOE a -ioe = IOE - -ioeIO :: IO a -> IOE a -ioeIO io = ioe (io >>= return . return) - -ioeErr :: Err a -> IOE a -ioeErr = ioe . return - -instance Monad IOE where - return a = ioe (return (return a)) - IOE c >>= f = IOE $ do - x <- c -- Err a - appIOE $ err ioeBad f x -- f :: a -> IOE a - -ioeBad :: String -> IOE a -ioeBad = ioe . return . Bad - -useIOE :: a -> IOE a -> IO a -useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return - -foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) -foldIOE f s xs = case xs of - [] -> return (s,Nothing) - x:xx -> do - ev <- ioeIO $ appIOE (f s x) - case ev of - Ok v -> foldIOE f v xx - Bad m -> return $ (s, Just m) - -putStrLnE :: String -> IOE () -putStrLnE = ioeIO . putStrLnFlush - -putStrE :: String -> IOE () -putStrE = ioeIO . putStrFlush - --- this is more verbose -putPointE :: Options -> String -> IOE a -> IOE a -putPointE = putPointEgen (oElem beSilent) - --- this is less verbose -putPointEsil :: Options -> String -> IOE a -> IOE a -putPointEsil = putPointEgen (not . oElem beVerbose) - -putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a -putPointEgen cond opts msg act = do - let ve x = if cond opts then return () else x - ve $ ioeIO $ putStrFlush msg - a <- act ---- ve $ ioeIO $ putShow' id a --- replace by a statistics command - ve $ ioeIO $ putStrFlush " " - ve $ ioeIO $ putCPU - return a -{- -putPointE :: Options -> String -> IOE a -> IOE a -putPointE opts msg act = do - let ve x = if oElem beVerbose opts then x else return () - ve $ putStrE msg - a <- act ---- ve $ ioeIO $ putShow' id a --- replace by a statistics command - ve $ ioeIO $ putCPU - return a --} - --- | forces verbosity -putPointEVerb :: Options -> String -> IOE a -> IOE a -putPointEVerb opts = putPointE (addOption beVerbose opts) - --- ((do {s <- readFile f; return (return s)}) ) -readFileIOE :: FilePath -> IOE (String) -readFileIOE f = ioe $ catch (readFileStrict f >>= return . return) - (\e -> return (Bad (show e))) - --- | like readFileIOE but look also in the GF library if file not found --- --- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@ --- (even if file is an absolute path, but this should always fail) --- it returns not only contents of the file, but also the path used -readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String) -readFileLibraryIOE ini f = ioe $ do - lp <- getLibraryPath - tryRead ini $ \_ -> - tryRead lp $ \e -> - return (Bad (show e)) - where - tryRead path onError = - catch (readFileStrict fpath >>= \s -> return (return (fpath,s))) - onError - where - fpath = path f - --- | example -koeIOE :: IO () -koeIOE = useIOE () $ do - s <- ioeIO $ getLine - s2 <- ioeErr $ mapM (!? 2) $ words s - ioeIO $ putStrLn s2 - diff --git a/src-3.0/GF/JavaScript/LexJS.hs b/src-3.0/GF/JavaScript/LexJS.hs deleted file mode 100644 index 242831195..000000000 --- a/src-3.0/GF/JavaScript/LexJS.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "LexJS.x" #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.JavaScript.LexJS where - - - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#else -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\x6d\x01\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x03\x00\xff\xff\x03\x00\xff\xff\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x02\x00\x0b\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x03\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x06\x00\x00\x00\x00\x00\xff\xff\x04\x00\x06\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\xff\xff\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x07\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x0c\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,13) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]] -{-# LINE 32 "LexJS.x" #-} - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words and symbols - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "return" (b "new" (b "function" (b "false" N N) N) (b "null" N N)) (b "true" (b "this" N N) (b "var" N N)) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> [Err pos] - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c - -alex_action_1 = tok (\p s -> PT p (TS $ share s)) -alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_3 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) -alex_action_4 = tok (\p s -> PT p (TI $ share s)) -alex_action_5 = tok (\p s -> PT p (TD $ share s)) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -{-# LINE 35 "GenericTemplate.hs" #-} - -{-# LINE 45 "GenericTemplate.hs" #-} - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - case s of - -1# -> (last_acc, input) - _ -> alex_scan_tkn' user orig_input len input s last_acc - -alex_scan_tkn' user orig_input len input s last_acc = - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src-3.0/GF/JavaScript/ParJS.hs b/src-3.0/GF/JavaScript/ParJS.hs deleted file mode 100644 index f57c44a22..000000000 --- a/src-3.0/GF/JavaScript/ParJS.hs +++ /dev/null @@ -1,1175 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module GF.JavaScript.ParJS where -import GF.JavaScript.AbsJS -import GF.JavaScript.LexJS -import GF.Data.ErrM -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.16 - -newtype HappyAbsSyn = HappyAbsSyn (() -> ()) -happyIn4 :: (Ident) -> (HappyAbsSyn ) -happyIn4 x = unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (Ident) -happyOut4 x = unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (Integer) -> (HappyAbsSyn ) -happyIn5 x = unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Integer) -happyOut5 x = unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (Double) -> (HappyAbsSyn ) -happyIn6 x = unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (Double) -happyOut6 x = unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (String) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (String) -happyOut7 x = unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Program) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (Program) -happyOut8 x = unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Element) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Element) -happyOut9 x = unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: ([Element]) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> ([Element]) -happyOut10 x = unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: ([Ident]) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> ([Ident]) -happyOut11 x = unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Stmt) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Stmt) -happyOut12 x = unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: ([Stmt]) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> ([Stmt]) -happyOut13 x = unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (DeclOrExpr) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (DeclOrExpr) -happyOut14 x = unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (DeclVar) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (DeclVar) -happyOut15 x = unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: ([DeclVar]) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> ([DeclVar]) -happyOut16 x = unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: (Expr) -> (HappyAbsSyn ) -happyIn17 x = unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> (Expr) -happyOut17 x = unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Expr) -> (HappyAbsSyn ) -happyIn18 x = unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (Expr) -happyOut18 x = unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: (Expr) -> (HappyAbsSyn ) -happyIn19 x = unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (Expr) -happyOut19 x = unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (Expr) -> (HappyAbsSyn ) -happyIn20 x = unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Expr) -happyOut20 x = unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: ([Expr]) -> (HappyAbsSyn ) -happyIn21 x = unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> ([Expr]) -happyOut21 x = unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Expr) -> (HappyAbsSyn ) -happyIn22 x = unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Expr) -happyOut22 x = unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: (Expr) -> (HappyAbsSyn ) -happyIn23 x = unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> (Expr) -happyOut23 x = unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (Expr) -> (HappyAbsSyn ) -happyIn24 x = unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Expr) -happyOut24 x = unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (Expr) -> (HappyAbsSyn ) -happyIn25 x = unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (Expr) -happyOut25 x = unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Expr) -> (HappyAbsSyn ) -happyIn26 x = unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Expr) -happyOut26 x = unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (Expr) -> (HappyAbsSyn ) -happyIn27 x = unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (Expr) -happyOut27 x = unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (Expr) -> (HappyAbsSyn ) -happyIn28 x = unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (Expr) -happyOut28 x = unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: (Expr) -> (HappyAbsSyn ) -happyIn29 x = unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (Expr) -happyOut29 x = unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (Expr) -> (HappyAbsSyn ) -happyIn30 x = unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (Expr) -happyOut30 x = unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: (Expr) -> (HappyAbsSyn ) -happyIn31 x = unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> (Expr) -happyOut31 x = unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: (Expr) -> (HappyAbsSyn ) -happyIn32 x = unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (Expr) -happyOut32 x = unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: (Expr) -> (HappyAbsSyn ) -happyIn33 x = unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (Expr) -happyOut33 x = unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: (Expr) -> (HappyAbsSyn ) -happyIn34 x = unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> (Expr) -happyOut34 x = unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: (Property) -> (HappyAbsSyn ) -happyIn35 x = unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> (Property) -happyOut35 x = unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: ([Property]) -> (HappyAbsSyn ) -happyIn36 x = unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> ([Property]) -happyOut36 x = unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: (PropertyName) -> (HappyAbsSyn ) -happyIn37 x = unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (PropertyName) -happyOut37 x = unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x00\x00\x9d\x00\x00\x00\x96\x00\x02\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\xab\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x02\xfe\xff\x30\x02\x00\x00\x02\x00\x9a\x00\x00\x00\x19\x02\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x3c\x00\x00\x00\xaa\x00\x93\x00\x92\x00\x7e\x00\x87\x00\x8b\x00\x00\x00\x00\x00\xeb\x01\x8a\x00\x89\x00\x83\x00\x12\x00\x30\x02\x61\x00\x30\x02\x30\x02\x00\x00\x00\x00\x82\x00\x00\x00\x72\x00\x00\x00\x30\x02\x30\x02\x00\x00\x20\x00\x00\x00\x00\x00\x30\x02\x00\x00\x6e\x00\x70\x00\x5d\x00\x30\x02\x00\x00\x5d\x00\x30\x02\x00\x00\x00\x00\x6d\x00\x6b\x00\x59\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\xd4\x01\x00\x00\xbd\x01\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x6a\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x01\x01\x00\x04\x01\x00\x00\x27\x00\x0b\x00\x00\x00\x80\x01\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x07\x00\x61\x01\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x42\x01\x00\x00\x05\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x69\x00\x00\x00\x13\x00\x23\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\xfd\xff\x4a\x00\x00\x00\x4a\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xf7\xff\x00\x00\xfe\xff\x00\x00\xfa\xff\xdd\xff\xdc\xff\xdb\xff\xda\xff\xf6\xff\xf8\xff\x00\x00\xc1\xff\xe4\xff\xe2\xff\xde\xff\xeb\xff\xcc\xff\xcb\xff\xca\xff\xc9\xff\xc8\xff\xc7\xff\xc6\xff\xc5\xff\xc4\xff\xc3\xff\xc2\xff\x00\x00\xee\xff\xd0\xff\xd8\xff\x00\x00\x00\x00\xd7\xff\x00\x00\xd6\xff\xd9\xff\xe8\xff\xfd\xff\xfc\xff\xfb\xff\xea\xff\xe7\xff\xec\xff\x00\x00\xcd\xff\xbf\xff\xf1\xff\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xcf\xff\xbc\xff\xbb\xff\x00\x00\xbe\xff\x00\x00\x00\x00\x00\x00\xd0\xff\x00\x00\x00\x00\x00\x00\xef\xff\xe5\xff\x00\x00\xe1\xff\x00\x00\xd1\xff\xd0\xff\x00\x00\xd3\xff\xbf\xff\xed\xff\xf2\xff\xd0\xff\xd4\xff\xf4\xff\x00\x00\xf5\xff\xd0\xff\xf0\xff\xe8\xff\x00\x00\xe9\xff\xe6\xff\x00\x00\x00\x00\x00\x00\xf5\xff\xce\xff\xbd\xff\xc0\xff\x00\x00\xdf\xff\xe0\xff\xd2\xff\xf3\xff\xee\xff\x00\x00\xe3\xff\xee\xff\x00\x00\xd5\xff\x00\x00\xf9\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x00\x00\x04\x00\x01\x00\x03\x00\x00\x00\x09\x00\x00\x00\x03\x00\x00\x00\x09\x00\x00\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x01\x00\x14\x00\x00\x00\x02\x00\x17\x00\x14\x00\x05\x00\x08\x00\x09\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x0c\x00\x1f\x00\x20\x00\x21\x00\x09\x00\x1f\x00\x20\x00\x21\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x05\x00\x00\x00\x02\x00\x08\x00\x14\x00\x0a\x00\x07\x00\x17\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x0c\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x00\x00\x14\x00\x14\x00\x08\x00\x17\x00\x0a\x00\x07\x00\x07\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x03\x00\x03\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x04\x00\x02\x00\x06\x00\x14\x00\x02\x00\x05\x00\x02\x00\x14\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0a\x00\x04\x00\x0b\x00\x05\x00\x05\x00\x0a\x00\x14\x00\x01\x00\x01\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x01\x00\x06\x00\x05\x00\x14\x00\x19\x00\x07\x00\x14\x00\x07\x00\x06\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x12\x00\xff\xff\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x12\x00\xff\xff\x14\x00\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x37\x00\xbf\xff\x35\x00\x38\x00\x37\x00\x6b\x00\x45\x00\x38\x00\x37\x00\x39\x00\x32\x00\x38\x00\x05\x00\x06\x00\x07\x00\x08\x00\x3f\x00\x03\x00\x2a\x00\x48\x00\x2a\x00\x03\x00\x49\x00\x40\x00\x41\x00\x43\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x00\x58\x00\x3a\x00\x3b\x00\x3c\x00\x69\x00\x3a\x00\x5e\x00\x3c\x00\x33\x00\x3a\x00\x3b\x00\x3c\x00\x05\x00\x06\x00\x07\x00\x08\x00\x50\x00\x09\x00\x2a\x00\x64\x00\x0a\x00\x03\x00\x0b\x00\x64\x00\x2a\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x00\x2c\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x50\x00\x50\x00\x03\x00\x03\x00\x4c\x00\x2a\x00\x0b\x00\x5a\x00\x51\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x69\x00\x66\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x67\x00\x03\x00\x68\x00\x04\x00\x03\x00\x5c\x00\x5d\x00\x62\x00\x03\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x59\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x63\x00\x4b\x00\x4a\x00\x4c\x00\x4f\x00\x50\x00\x03\x00\x53\x00\x54\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x5d\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x35\x00\x55\x00\x56\x00\x03\x00\xff\xff\x57\x00\x03\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x60\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x46\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x35\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x57\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x5f\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x44\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x2d\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x3d\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1d\x00\x00\x00\x1e\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x1e\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x1e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x30\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x00\x00\x25\x00\x26\x00\x00\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x00\x00\x25\x00\x26\x00\x00\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (1, 68) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68) - ] - -happy_n_terms = 26 :: Int -happy_n_nonterms = 34 :: Int - -happyReduce_1 = happySpecReduce_1 0# happyReduction_1 -happyReduction_1 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> - happyIn4 - (Ident happy_var_1 - )} - -happyReduce_2 = happySpecReduce_1 1# happyReduction_2 -happyReduction_2 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn5 - ((read happy_var_1) :: Integer - )} - -happyReduce_3 = happySpecReduce_1 2# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> - happyIn6 - ((read happy_var_1) :: Double - )} - -happyReduce_4 = happySpecReduce_1 3# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn7 - (happy_var_1 - )} - -happyReduce_5 = happySpecReduce_1 4# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - happyIn8 - (Program (reverse happy_var_1) - )} - -happyReduce_6 = happyReduce 8# 5# happyReduction_6 -happyReduction_6 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut4 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - case happyOut13 happy_x_7 of { happy_var_7 -> - happyIn9 - (FunDef happy_var_2 happy_var_4 (reverse happy_var_7) - ) `HappyStk` happyRest}}} - -happyReduce_7 = happySpecReduce_1 5# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn9 - (ElStmt happy_var_1 - )} - -happyReduce_8 = happySpecReduce_0 6# happyReduction_8 -happyReduction_8 = happyIn10 - ([] - ) - -happyReduce_9 = happySpecReduce_2 6# happyReduction_9 -happyReduction_9 happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn10 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_10 = happySpecReduce_0 7# happyReduction_10 -happyReduction_10 = happyIn11 - ([] - ) - -happyReduce_11 = happySpecReduce_1 7# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - happyIn11 - ((:[]) happy_var_1 - )} - -happyReduce_12 = happySpecReduce_3 7# happyReduction_12 -happyReduction_12 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - case happyOut11 happy_x_3 of { happy_var_3 -> - happyIn11 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_13 = happySpecReduce_3 8# happyReduction_13 -happyReduction_13 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut13 happy_x_2 of { happy_var_2 -> - happyIn12 - (SCompound (reverse happy_var_2) - )} - -happyReduce_14 = happySpecReduce_2 8# happyReduction_14 -happyReduction_14 happy_x_2 - happy_x_1 - = happyIn12 - (SReturnVoid - ) - -happyReduce_15 = happySpecReduce_3 8# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut22 happy_x_2 of { happy_var_2 -> - happyIn12 - (SReturn happy_var_2 - )} - -happyReduce_16 = happySpecReduce_2 8# happyReduction_16 -happyReduction_16 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - happyIn12 - (SDeclOrExpr happy_var_1 - )} - -happyReduce_17 = happySpecReduce_0 9# happyReduction_17 -happyReduction_17 = happyIn13 - ([] - ) - -happyReduce_18 = happySpecReduce_2 9# happyReduction_18 -happyReduction_18 happy_x_2 - happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn13 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_19 = happySpecReduce_2 10# happyReduction_19 -happyReduction_19 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn14 - (Decl happy_var_2 - )} - -happyReduce_20 = happySpecReduce_1 10# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn14 - (DExpr happy_var_1 - )} - -happyReduce_21 = happySpecReduce_1 11# happyReduction_21 -happyReduction_21 happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - happyIn15 - (DVar happy_var_1 - )} - -happyReduce_22 = happySpecReduce_3 11# happyReduction_22 -happyReduction_22 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn15 - (DInit happy_var_1 happy_var_3 - )}} - -happyReduce_23 = happySpecReduce_0 12# happyReduction_23 -happyReduction_23 = happyIn16 - ([] - ) - -happyReduce_24 = happySpecReduce_1 12# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn16 - ((:[]) happy_var_1 - )} - -happyReduce_25 = happySpecReduce_3 12# happyReduction_25 -happyReduction_25 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_3 of { happy_var_3 -> - happyIn16 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_26 = happySpecReduce_3 13# happyReduction_26 -happyReduction_26 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn17 - (EAssign happy_var_1 happy_var_3 - )}} - -happyReduce_27 = happySpecReduce_1 13# happyReduction_27 -happyReduction_27 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn17 - (happy_var_1 - )} - -happyReduce_28 = happyReduce 5# 14# happyReduction_28 -happyReduction_28 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut4 happy_x_2 of { happy_var_2 -> - case happyOut21 happy_x_4 of { happy_var_4 -> - happyIn18 - (ENew happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_29 = happySpecReduce_1 14# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - happyIn18 - (happy_var_1 - )} - -happyReduce_30 = happySpecReduce_3 15# happyReduction_30 -happyReduction_30 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - case happyOut4 happy_x_3 of { happy_var_3 -> - happyIn19 - (EMember happy_var_1 happy_var_3 - )}} - -happyReduce_31 = happyReduce 4# 15# happyReduction_31 -happyReduction_31 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut19 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn19 - (EIndex happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_32 = happyReduce 4# 15# happyReduction_32 -happyReduction_32 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut19 happy_x_1 of { happy_var_1 -> - case happyOut21 happy_x_3 of { happy_var_3 -> - happyIn19 - (ECall happy_var_1 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_33 = happySpecReduce_1 15# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn19 - (happy_var_1 - )} - -happyReduce_34 = happySpecReduce_1 16# happyReduction_34 -happyReduction_34 happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - happyIn20 - (EVar happy_var_1 - )} - -happyReduce_35 = happySpecReduce_1 16# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn20 - (EInt happy_var_1 - )} - -happyReduce_36 = happySpecReduce_1 16# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn20 - (EDbl happy_var_1 - )} - -happyReduce_37 = happySpecReduce_1 16# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn20 - (EStr happy_var_1 - )} - -happyReduce_38 = happySpecReduce_1 16# happyReduction_38 -happyReduction_38 happy_x_1 - = happyIn20 - (ETrue - ) - -happyReduce_39 = happySpecReduce_1 16# happyReduction_39 -happyReduction_39 happy_x_1 - = happyIn20 - (EFalse - ) - -happyReduce_40 = happySpecReduce_1 16# happyReduction_40 -happyReduction_40 happy_x_1 - = happyIn20 - (ENull - ) - -happyReduce_41 = happySpecReduce_1 16# happyReduction_41 -happyReduction_41 happy_x_1 - = happyIn20 - (EThis - ) - -happyReduce_42 = happyReduce 7# 16# happyReduction_42 -happyReduction_42 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut11 happy_x_3 of { happy_var_3 -> - case happyOut13 happy_x_6 of { happy_var_6 -> - happyIn20 - (EFun happy_var_3 (reverse happy_var_6) - ) `HappyStk` happyRest}} - -happyReduce_43 = happySpecReduce_3 16# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_2 of { happy_var_2 -> - happyIn20 - (EArray happy_var_2 - )} - -happyReduce_44 = happySpecReduce_3 16# happyReduction_44 -happyReduction_44 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut36 happy_x_2 of { happy_var_2 -> - happyIn20 - (EObj happy_var_2 - )} - -happyReduce_45 = happyReduce 5# 16# happyReduction_45 -happyReduction_45 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_2 of { happy_var_2 -> - case happyOut21 happy_x_4 of { happy_var_4 -> - happyIn20 - (eseq1_ happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_46 = happySpecReduce_3 16# happyReduction_46 -happyReduction_46 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut22 happy_x_2 of { happy_var_2 -> - happyIn20 - (happy_var_2 - )} - -happyReduce_47 = happySpecReduce_0 17# happyReduction_47 -happyReduction_47 = happyIn21 - ([] - ) - -happyReduce_48 = happySpecReduce_1 17# happyReduction_48 -happyReduction_48 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn21 - ((:[]) happy_var_1 - )} - -happyReduce_49 = happySpecReduce_3 17# happyReduction_49 -happyReduction_49 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut21 happy_x_3 of { happy_var_3 -> - happyIn21 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_50 = happySpecReduce_1 18# happyReduction_50 -happyReduction_50 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn22 - (happy_var_1 - )} - -happyReduce_51 = happySpecReduce_1 19# happyReduction_51 -happyReduction_51 happy_x_1 - = case happyOut24 happy_x_1 of { happy_var_1 -> - happyIn23 - (happy_var_1 - )} - -happyReduce_52 = happySpecReduce_1 20# happyReduction_52 -happyReduction_52 happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - happyIn24 - (happy_var_1 - )} - -happyReduce_53 = happySpecReduce_1 21# happyReduction_53 -happyReduction_53 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn25 - (happy_var_1 - )} - -happyReduce_54 = happySpecReduce_1 22# happyReduction_54 -happyReduction_54 happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - happyIn26 - (happy_var_1 - )} - -happyReduce_55 = happySpecReduce_1 23# happyReduction_55 -happyReduction_55 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn27 - (happy_var_1 - )} - -happyReduce_56 = happySpecReduce_1 24# happyReduction_56 -happyReduction_56 happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn28 - (happy_var_1 - )} - -happyReduce_57 = happySpecReduce_1 25# happyReduction_57 -happyReduction_57 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn29 - (happy_var_1 - )} - -happyReduce_58 = happySpecReduce_1 26# happyReduction_58 -happyReduction_58 happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn30 - (happy_var_1 - )} - -happyReduce_59 = happySpecReduce_1 27# happyReduction_59 -happyReduction_59 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn31 - (happy_var_1 - )} - -happyReduce_60 = happySpecReduce_1 28# happyReduction_60 -happyReduction_60 happy_x_1 - = case happyOut33 happy_x_1 of { happy_var_1 -> - happyIn32 - (happy_var_1 - )} - -happyReduce_61 = happySpecReduce_1 29# happyReduction_61 -happyReduction_61 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - happyIn33 - (happy_var_1 - )} - -happyReduce_62 = happySpecReduce_1 30# happyReduction_62 -happyReduction_62 happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - happyIn34 - (happy_var_1 - )} - -happyReduce_63 = happySpecReduce_3 31# happyReduction_63 -happyReduction_63 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn35 - (Prop happy_var_1 happy_var_3 - )}} - -happyReduce_64 = happySpecReduce_0 32# happyReduction_64 -happyReduction_64 = happyIn36 - ([] - ) - -happyReduce_65 = happySpecReduce_1 32# happyReduction_65 -happyReduction_65 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn36 - ((:[]) happy_var_1 - )} - -happyReduce_66 = happySpecReduce_3 32# happyReduction_66 -happyReduction_66 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_3 of { happy_var_3 -> - happyIn36 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_67 = happySpecReduce_1 33# happyReduction_67 -happyReduction_67 happy_x_1 - = case happyOut4 happy_x_1 of { happy_var_1 -> - happyIn37 - (IdentPropName happy_var_1 - )} - -happyReduce_68 = happySpecReduce_1 33# happyReduction_68 -happyReduction_68 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn37 - (StringPropName happy_var_1 - )} - -happyNewToken action sts stk [] = - happyDoAction 25# (error "reading EOF!") action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS "(") -> cont 1#; - PT _ (TS ")") -> cont 2#; - PT _ (TS "{") -> cont 3#; - PT _ (TS "}") -> cont 4#; - PT _ (TS ",") -> cont 5#; - PT _ (TS ";") -> cont 6#; - PT _ (TS "=") -> cont 7#; - PT _ (TS ".") -> cont 8#; - PT _ (TS "[") -> cont 9#; - PT _ (TS "]") -> cont 10#; - PT _ (TS ":") -> cont 11#; - PT _ (TS "false") -> cont 12#; - PT _ (TS "function") -> cont 13#; - PT _ (TS "new") -> cont 14#; - PT _ (TS "null") -> cont 15#; - PT _ (TS "return") -> cont 16#; - PT _ (TS "this") -> cont 17#; - PT _ (TS "true") -> cont 18#; - PT _ (TS "var") -> cont 19#; - PT _ (TV happy_dollar_dollar) -> cont 20#; - PT _ (TI happy_dollar_dollar) -> cont 21#; - PT _ (TD happy_dollar_dollar) -> cont 22#; - PT _ (TL happy_dollar_dollar) -> cont 23#; - _ -> cont 24#; - _ -> happyError' (tk:tks) - } - -happyError_ tk tks = happyError' (tk:tks) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = (thenM) -happyReturn :: () => a -> Err a -happyReturn = (returnM) -happyThen1 m k tks = (thenM) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (returnM) a -happyError' :: () => [Token] -> Err a -happyError' = happyError - -pProgram tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut8 x)) - -happySeq = happyDontSeq - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -eseq1_ x_ xs_ = ESeq (x_ : xs_) -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- $Id$ - -{-# LINE 28 "GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - -{-# LINE 49 "GenericTemplate.hs" #-} - -{-# LINE 59 "GenericTemplate.hs" #-} - -{-# LINE 68 "GenericTemplate.hs" #-} - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - -{-# LINE 127 "GenericTemplate.hs" #-} - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 170 "GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/src-3.0/GF/JavaScript/SkelJS.hs b/src-3.0/GF/JavaScript/SkelJS.hs deleted file mode 100644 index f8cd588a7..000000000 --- a/src-3.0/GF/JavaScript/SkelJS.hs +++ /dev/null @@ -1,80 +0,0 @@ -module GF.JavaScript.SkelJS where - --- Haskell module generated by the BNF converter - -import GF.JavaScript.AbsJS -import GF.Data.ErrM -type Result = Err String - -failure :: Show a => a -> Result -failure x = Bad $ "Undefined case: " ++ show x - -transIdent :: Ident -> Result -transIdent x = case x of - Ident str -> failure x - - -transProgram :: Program -> Result -transProgram x = case x of - Program elements -> failure x - - -transElement :: Element -> Result -transElement x = case x of - FunDef id ids stmts -> failure x - ElStmt stmt -> failure x - - -transStmt :: Stmt -> Result -transStmt x = case x of - SCompound stmts -> failure x - SReturnVoid -> failure x - SReturn expr -> failure x - SDeclOrExpr declorexpr -> failure x - - -transDeclOrExpr :: DeclOrExpr -> Result -transDeclOrExpr x = case x of - Decl declvars -> failure x - DExpr expr -> failure x - - -transDeclVar :: DeclVar -> Result -transDeclVar x = case x of - DVar id -> failure x - DInit id expr -> failure x - - -transExpr :: Expr -> Result -transExpr x = case x of - EAssign expr0 expr -> failure x - ENew id exprs -> failure x - EMember expr id -> failure x - EIndex expr0 expr -> failure x - ECall expr exprs -> failure x - EVar id -> failure x - EInt n -> failure x - EDbl d -> failure x - EStr str -> failure x - ETrue -> failure x - EFalse -> failure x - ENull -> failure x - EThis -> failure x - EFun ids stmts -> failure x - EArray exprs -> failure x - EObj propertys -> failure x - ESeq exprs -> failure x - - -transProperty :: Property -> Result -transProperty x = case x of - Prop propertyname expr -> failure x - - -transPropertyName :: PropertyName -> Result -transPropertyName x = case x of - IdentPropName id -> failure x - StringPropName str -> failure x - - - diff --git a/src-3.0/GF/JavaScript/TestJS.hs b/src-3.0/GF/JavaScript/TestJS.hs deleted file mode 100644 index 3ddb52074..000000000 --- a/src-3.0/GF/JavaScript/TestJS.hs +++ /dev/null @@ -1,58 +0,0 @@ --- automatically generated by BNF Converter -module Main where - - -import IO ( stdin, hGetContents ) -import System ( getArgs, getProgName ) - -import GF.JavaScript.LexJS -import GF.JavaScript.ParJS -import GF.JavaScript.SkelJS -import GF.JavaScript.PrintJS -import GF.JavaScript.AbsJS - - - - -import GF.Data.ErrM - -type ParseFun a = [Token] -> Err a - -myLLexer = myLexer - -type Verbosity = Int - -putStrV :: Verbosity -> String -> IO () -putStrV v s = if v > 1 then putStrLn s else return () - -runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () -runFile v p f = putStrLn f >> readFile f >>= run v p - -run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () -run v p s = let ts = myLLexer s in case p ts of - Bad s -> do putStrLn "\nParse Failed...\n" - putStrV v "Tokens:" - putStrV v $ show ts - putStrLn s - Ok tree -> do putStrLn "\nParse Successful!" - showTree v tree - - - -showTree :: (Show a, Print a) => Int -> a -> IO () -showTree v tree - = do - putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree - putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree - -main :: IO () -main = do args <- getArgs - case args of - [] -> hGetContents stdin >>= run 2 pProgram - "-s":fs -> mapM_ (runFile 0 pProgram) fs - fs -> mapM_ (runFile 2 pProgram) fs - - - - - diff --git a/src-3.0/GF/OldParsing/CFGrammar.hs b/src-3.0/GF/OldParsing/CFGrammar.hs deleted file mode 100644 index 5a71fe0ab..000000000 --- a/src-3.0/GF/OldParsing/CFGrammar.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CFGrammar --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:41 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Definitions of context-free grammars, --- parser information and chart conversion ----------------------------------------------------------------------- - -module GF.OldParsing.CFGrammar - (-- * Type definitions - Grammar, - Rule(..), - CFParser, - -- * Parser information - pInfo, - PInfo(..), - -- * Building parse charts - edges2chart, - -- * Grammar checking - checkGrammar - ) where - -import GF.System.Tracing - --- haskell modules: -import Data.Array --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc -import qualified GF.CF.CF as CF --- parser modules: -import GF.OldParsing.Utilities -import GF.Printing.PrintParser - - ------------------------------------------------------------- --- type definitions - -type Grammar n c t = [Rule n c t] -data Rule n c t = Rule c [Symbol c t] n - deriving (Eq, Ord, Show) - - -type CFParser n c t = PInfo n c t -> [c] -> Input t -> [Edge (Rule n c t)] --- - - - - - - - - - - - - - - - - - ^^^ possible starting categories - - ------------------------------------------------------------- --- parser information - -pInfo :: (Ord n, Ord c, Ord t) => Grammar n c t -> PInfo n c t - -data PInfo n c t - = PInfo { grammarTokens :: SList t, - nameRules :: Assoc n (SList (Rule n c t)), - topdownRules :: Assoc c (SList (Rule n c t)), - bottomupRules :: Assoc (Symbol c t) (SList (Rule n c t)), - emptyLeftcornerRules :: Assoc c (SList (Rule n c t)), - emptyCategories :: Set c, - cyclicCategories :: SList c, - -- ^^ONLY FOR DIRECT CYCLIC RULES!!! - leftcornerTokens :: Assoc c (SList t) - -- ^^DOES NOT WORK WITH EMPTY RULES!!! - } - --- this is not permanent... -pInfo grammar = pInfo' (filter (not.isCyclic) grammar) - -pInfo' grammar = tracePrt "#parserInfo" prt $ - PInfo grToks nmRules tdRules buRules elcRules emptyCats cyclicCats leftToks - where grToks = union [ nubsort [ tok | Tok tok <- rhs ] | Rule _ rhs _ <- grammar ] - nmRules = accumAssoc id [ (name, rule) | rule@(Rule _ _ name) <- grammar ] - tdRules = accumAssoc id [ (cat, rule) | rule@(Rule cat _ _) <- grammar ] - buRules = accumAssoc id [ (next, rule) | rule@(Rule _ (next:_) _) <- grammar ] - elcRules = accumAssoc id $ limit lc emptyRules - leftToks = accumAssoc id $ limit lc $ - nubsort [ (cat, token) | Rule cat (Tok token:_) _ <- grammar ] - lc (left, res) = nubsort [ (cat, res) | Rule cat _ _ <- buRules ? Cat left ] - emptyRules = nubsort [ (cat, rule) | rule@(Rule cat [] _) <- grammar ] - emptyCats = listSet $ limitEmpties $ map fst emptyRules - limitEmpties es = if es==es' then es else limitEmpties es' - where es' = nubsort [ cat | Rule cat rhs _ <- grammar, - all (symbol (`elem` es) (const False)) rhs ] - cyclicCats = nubsort [ cat | Rule cat [Cat cat'] _ <- grammar, cat == cat' ] - -isCyclic (Rule cat [Cat cat'] _) = cat==cat' -isCyclic _ = False - ------------------------------------------------------------- --- building parse charts - -edges2chart :: (Ord n, Ord c, Ord t) => Input t -> - [Edge (Rule n c t)] -> ParseChart n (Edge c) - ----------- - -edges2chart input edges - = accumAssoc id [ (Edge i k cat, (name, children i k rhs)) | - Edge i k (Rule cat rhs name) <- edges ] - where children i k [] = [ [] | i == k ] - children i k (Tok tok:rhs) = [ rest | i <= k, - j <- (inputFrom input ! i) ? tok, - rest <- children j k rhs ] - children i k (Cat cat:rhs) = [ Edge i j cat : rest | i <= k, - j <- echart ? (i, cat), - rest <- children j k rhs ] - echart = accumAssoc id [ ((i, cat), j) | Edge i j (Rule cat _ _) <- edges ] - - ------------------------------------------------------------- --- grammar checking - -checkGrammar :: (Ord n, Ord c, Ord t, Print n, Print c, Print t) => - Grammar n c t -> [String] - ----------- - -checkGrammar rules = [ "rhs category does not exist: " ++ prt cat ++ "\n" ++ - " in rule: " ++ prt rule | - rule@(Rule _ rhs _) <- rules, - Cat cat <- rhs, cat `notElem` cats ] - where cats = nubsort [ cat | Rule cat _ _ <- rules ] - - ------------------------------------------------------------- --- pretty-printing - -instance (Print n, Print c, Print t) => Print (Rule n c t) where - prt (Rule cat rhs name) = prt name ++ ". " ++ prt cat ++ " -> " ++ prt rhs ++ - (if null rhs then ".\n" else "\n") - prtList = concatMap prt - - -instance (Ord n, Ord c, Ord t) => Print (PInfo n c t) where - prt pI = "[ tokens=" ++ show (length (grammarTokens pI)) ++ - "; names=" ++ sla nameRules ++ - "; tdCats=" ++ sla topdownRules ++ - "; buCats=" ++ sla bottomupRules ++ - "; elcCats=" ++ sla emptyLeftcornerRules ++ - "; eCats=" ++ sla emptyCategories ++ - "; cCats=" ++ show (length (cyclicCategories pI)) ++ - -- "; lctokCats=" ++ sla leftcornerTokens ++ - " ]" - where sla f = show $ length $ aElems $ f pI - - diff --git a/src-3.0/GF/OldParsing/ConvertFiniteGFC.hs b/src-3.0/GF/OldParsing/ConvertFiniteGFC.hs deleted file mode 100644 index 25ed3fdb3..000000000 --- a/src-3.0/GF/OldParsing/ConvertFiniteGFC.hs +++ /dev/null @@ -1,283 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:42 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Calculating the finiteness of each type in a grammar ------------------------------------------------------------------------------ - -module GF.OldParsing.ConvertFiniteGFC where - -import GF.Data.Operations -import GF.Canon.GFC -import GF.Canon.MkGFC -import GF.Canon.AbsGFC -import GF.Infra.Ident (Ident(..)) -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Data.BacktrackM - -type Cat = Ident -type Name = Ident - -type CnvMonad a = BacktrackM () a - -convertGrammar :: CanonGrammar -> CanonGrammar -convertGrammar = canon2grammar . convertCanon . grammar2canon - -convertCanon :: Canon -> Canon -convertCanon (Gr modules) = Gr (map (convertModule split) modules) - where split = calcSplitable modules - -convertModule :: Splitable -> Module -> Module -convertModule split (Mod mtyp ext op fl defs) - = Mod mtyp ext op fl newDefs - where newDefs = solutions defMonad () - defMonad = member defs >>= convertDef split - ----------------------------------------------------------------------- --- the main conversion function -convertDef :: Splitable -> Def -> CnvMonad Def - --- converting abstract "cat" definitions -convertDef split (AbsDCat cat decls cidents) - = case splitableCat split cat of - Just newCats -> do newCat <- member newCats - return $ AbsDCat newCat decls cidents - Nothing -> do (newCat, newDecls) <- expandDecls cat decls - return $ AbsDCat newCat newDecls cidents - where expandDecls cat [] = return (cat, []) - expandDecls cat (decl@(Decl var typ) : decls) - = do (newCat, newDecls) <- expandDecls cat decls - let argCat = resultCat typ - case splitableCat split argCat of - Nothing -> return (newCat, decl : newDecls) - Just newArgs -> do newArg <- member newArgs - return (mergeArg newCat newArg, newDecls) - --- converting abstract "fun" definitions -convertDef split (AbsDFun fun typ@(EAtom (AC (CIQ mod cat))) def) - = case splitableFun split fun of - Just newCat -> return (AbsDFun fun (EAtom (AC (CIQ mod newCat))) def) - Nothing -> do newTyp <- expandType split [] typ - return (AbsDFun fun newTyp def) -convertDef split (AbsDFun fun typ def) - = do newTyp <- expandType split [] typ - return (AbsDFun fun newTyp def) - --- converting concrete "lincat" definitions -convertDef split (CncDCat cat ctype x y) - = case splitableCat split cat of - Just newCats -> do newCat <- member newCats - return $ CncDCat newCat ctype x y - Nothing -> return $ CncDCat cat ctype x y - --- converting concrete "lin" definitions -convertDef split (CncDFun fun (CIQ mod cat) args linterm x) - = case splitableFun split fun of - Just newCat -> return $ CncDFun fun (CIQ mod newCat) args linterm x - Nothing -> return $ CncDFun fun (CIQ mod cat) args linterm x - -convertDef _ def = return def - ----------------------------------------------------------------------- --- expanding type expressions - -expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp -expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b) - = case splitableCat split cat of - Nothing -> do b' <- expandType split env b - return (EProd x a b') - Just newCats -> do newCat <- member newCats - b' <- expandType split ((x,newCat):env) b - return (EProd x (EAtom (AC (CIQ mod newCat))) b') -expandType split env (EProd x a b) - = do a' <- expandType split env a - b' <- expandType split env b - return (EProd x a' b') -expandType split env app - = expandApp split env [] app - -expandApp :: Splitable -> [(Ident, Cat)] -> [Cat] -> Exp -> CnvMonad Exp -expandApp split env addons (EAtom (AC (CIQ mod cat))) - = return (EAtom (AC (CIQ mod (foldl mergeArg cat addons)))) -expandApp split env addons (EApp exp arg@(EAtom (AC (CIQ mod fun)))) - = case splitableFun split fun of - Just newCat -> expandApp split env (newCat:addons) exp - Nothing -> do exp' <- expandApp split env addons exp - return (EApp exp' arg) -expandApp split env addons (EApp exp arg@(EAtom (AV x))) - = case lookup x env of - Just newCat -> expandApp split env (newCat:addons) exp - Nothing -> do exp' <- expandApp split env addons exp - return (EApp exp' arg) - ----------------------------------------------------------------------- --- splitable categories (finite, no dependencies) --- they should also be used as some dependency - -type Splitable = (Assoc Cat [Cat], Assoc Name Cat) - -splitableCat :: Splitable -> Cat -> Maybe [Cat] -splitableCat = lookupAssoc . fst - -splitableFun :: Splitable -> Name -> Maybe Cat -splitableFun = lookupAssoc . snd - -calcSplitable :: [Module] -> Splitable -calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns) - where splitableCats = tracePrt "splitableCats" (prtSep " ") $ - groupPairs $ nubsort - [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ] - - splitableFuns = tracePrt "splitableFuns" (prtSep " ") $ - nubsort - [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ] - - constantCats = tracePrt "constantCats" (prtSep " ") $ - [ (cat, fun) | - AbsDFun fun (EAtom (AC (CIQ _ cat))) _ <- absDefs, - dependentConstants ?= cat ] - - dependentConstants = listSet $ - tracePrt "dep consts" prt $ - dependentCats <\\> funCats - - funCats = tracePrt "fun cats" prt $ - nubsort [ resultCat typ | - AbsDFun _ typ@(EProd _ _ _) _ <- absDefs ] - - dependentCats = tracePrt "dep cats" prt $ - nubsort [ cat | AbsDCat _ decls _ <- absDefs, - Decl _ (EAtom (AC (CIQ _ cat))) <- decls ] - - absDefs = concat [ defs | Mod (MTAbs _) _ _ _ defs <- modules ] - - ----------------------------------------------------------------------- --- utilities - --- the main result category of a type expression -resultCat :: Exp -> Cat -resultCat (EProd _ _ b) = resultCat b -resultCat (EApp a _) = resultCat a -resultCat (EAtom (AC (CIQ _ cat))) = cat - --- mergeing categories -mergeCats :: String -> String -> String -> Cat -> Cat -> Cat -mergeCats before middle after (IC cat) (IC arg) - = IC (before ++ cat ++ middle ++ arg ++ after) - -mergeFun, mergeArg :: Cat -> Cat -> Cat -mergeFun = mergeCats "{" ":" "}" -mergeArg = mergeCats "" "" "" - ----------------------------------------------------------------------- --- obsolete? - -{- -type FiniteCats = Assoc Cat Integer - -calculateFiniteness :: Canon -> FiniteCats -calculateFiniteness canon@(Gr modules) - = trace2 "#typeInfo" (prt tInfo) $ - finiteCats - - where finiteCats = listAssoc [ (cat, fin) | (cat, Just fin) <- finiteInfo ] - finiteInfo = map finInfo groups - - finInfo :: (Cat, [[Cat]]) -> (Cat, Maybe Integer) - finInfo (cat, ctxts) - | cyclicCats ?= cat = (cat, Nothing) - | otherwise = (cat, fmap (sum . map product) $ - sequence (map (sequence . map lookFinCat) ctxts)) - - lookFinCat :: Cat -> Maybe Integer - lookFinCat cat = maybe (error "lookFinCat: Nothing") id $ - lookup cat finiteInfo - - cyclicCats :: Set Cat - cyclicCats = listSet $ - tracePrt "cyclic cats" prt $ - union $ map nubsort $ cyclesIn dependencies - - dependencies :: [(Cat, [Cat])] - dependencies = tracePrt "dependencies" (prtAfter "\n") $ - mapSnd (union . nubsort) groups - - groups :: [(Cat, [[Cat]])] - groups = tracePrt "groups" (prtAfter "\n") $ - mapSnd (map snd) $ groupPairs (nubsort allFuns) - - allFuns = tracePrt "all funs" (prtAfter "\n") $ - [ (cat, (fun, ctxt)) | - Mod (MTAbs _) _ _ _ defs <- modules, - AbsDFun fun typ _ <- defs, - let (cat, ctxt) = err error id $ typeForm typ ] - - tInfo = calculateTypeInfo 30 finiteCats (splitDefs canon) - --- | stolen from 'Macros.qTypeForm', converted to GFC, and severely simplified -typeForm :: Monad m => Exp -> m (Cat, [Cat]) -typeForm t = case t of - EProd x a b -> do - (cat, ctxt) <- typeForm b - a' <- stripType a - return (cat, a':ctxt) - EApp c a -> do - (cat, _) <- typeForm c - return (cat, []) - EAtom (AC (CIQ _ con)) -> - return (con, []) - _ -> - fail $ "no normal form of type: " ++ prt t - -stripType :: Monad m => Exp -> m Cat -stripType (EApp c a) = stripType c -stripType (EAtom (AC (CIQ _ con))) = return con -stripType t = fail $ "can't strip type: " ++ prt t - -mapSnd f xs = [ (a, f b) | (a, b) <- xs ] --} - ----------------------------------------------------------------------- --- obsolete? - -{- -type SplitDefs = ([Def], [Def], [Def], [Def]) ------ AbsDCat AbsDFun CncDCat CncDFun - -splitDefs :: Canon -> SplitDefs -splitDefs (Gr modules) = foldr splitDef ([], [], [], []) $ - concat [ defs | Mod _ _ _ _ defs <- modules ] - -splitDef :: Def -> SplitDefs -> SplitDefs -splitDef ac@(AbsDCat _ _ _) (acs, afs, ccs, cfs) = (ac:acs, afs, ccs, cfs) -splitDef af@(AbsDFun _ _ _) (acs, afs, ccs, cfs) = (acs, af:afs, ccs, cfs) -splitDef cc@(CncDCat _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, cc:ccs, cfs) -splitDef cf@(CncDFun _ _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, ccs, cf:cfs) -splitDef _ sd = sd - ---calculateTypeInfo :: Integer -> FiniteCats -> SplitDefs -> ? -calculateTypeInfo maxFin allFinCats (acs, afs, ccs, cfs) - = (depCatsToExpand, catsToSplit) - where absDefsToExpand = tracePrt "absDefsToExpand" prt $ - [ ((cat, fin), cats) | - AbsDCat cat args _ <- acs, - not (null args), - cats <- mapM catOfDecl args, - fin <- lookupAssoc allFinCats cat, - fin <= maxFin - ] - (depCatsToExpand, argsCats') = unzip absDefsToExpand - catsToSplit = union (map nubsort argsCats') - catOfDecl (Decl _ exp) = err fail return $ stripType exp --} diff --git a/src-3.0/GF/OldParsing/ConvertFiniteSimple.hs b/src-3.0/GF/OldParsing/ConvertFiniteSimple.hs deleted file mode 100644 index a05092550..000000000 --- a/src-3.0/GF/OldParsing/ConvertFiniteSimple.hs +++ /dev/null @@ -1,121 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:43 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Calculating the finiteness of each type in a grammar ------------------------------------------------------------------------------ - -module GF.OldParsing.ConvertFiniteSimple - (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - -import GF.Data.Operations -import GF.Infra.Ident (Ident(..)) -import GF.OldParsing.SimpleGFC -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Data.BacktrackM - -type CnvMonad a = BacktrackM () a - -convertGrammar :: Grammar -> Grammar -convertGrammar rules = solutions cnvMonad () - where split = calcSplitable rules - cnvMonad = member rules >>= convertRule split - -convertRule :: Splitable -> Rule -> CnvMonad Rule -convertRule split (Rule name typing term) - = do newTyping <- convertTyping split name typing - return $ Rule name newTyping term - -convertTyping :: Splitable -> Name -> Typing -> CnvMonad Typing -convertTyping split name (typ, decls) - = case splitableFun split name of - Just newCat -> return (newCat :@ [], decls) - Nothing -> expandTyping split [] typ decls [] - - -expandTyping :: Splitable -> [(Var, Cat)] -> Type -> [Decl] -> [Decl] -> CnvMonad Typing -expandTyping split env (cat :@ atoms) [] decls - = return (substAtoms split env cat atoms [], reverse decls) -expandTyping split env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone - = do env' <- calcNewEnv - expandTyping split env' typ declsToDo (decl : declsDone) - where decl = x ::: substAtoms split env xcat xatoms [] - calcNewEnv = case splitableCat split xcat of - Just newCats -> do newCat <- member newCats - return ((x,newCat) : env) - Nothing -> return env - -substAtoms :: Splitable -> [(Var, Cat)] -> Cat -> [Atom] -> [Atom] -> Type -substAtoms split env cat [] atoms = cat :@ reverse atoms -substAtoms split env cat (atom:atomsToDo) atomsDone - = case atomLookup split env atom of - Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone - Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone) - -atomLookup split env (AVar x) = lookup x env -atomLookup split env (ACon con) = splitableFun split (constr2name con) - - ----------------------------------------------------------------------- --- splitable categories (finite, no dependencies) --- they should also be used as some dependency - -type Splitable = (Assoc Cat [Cat], Assoc Name Cat) - -splitableCat :: Splitable -> Cat -> Maybe [Cat] -splitableCat = lookupAssoc . fst - -splitableFun :: Splitable -> Name -> Maybe Cat -splitableFun = lookupAssoc . snd - -calcSplitable :: [Rule] -> Splitable -calcSplitable rules = (listAssoc splitableCats, listAssoc splitableFuns) - where splitableCats = tracePrt "splitableCats" (prtSep " ") $ - groupPairs $ nubsort - [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ] - - splitableFuns = tracePrt "splitableFuns" (prtSep " ") $ - nubsort - [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ] - - constantCats = tracePrt "constantCats" (prtSep " ") $ - [ (cat, fun) | - Rule fun (cat :@ [], []) _ <- rules, - dependentConstants ?= cat ] - - dependentConstants = listSet $ - tracePrt "dep consts" prt $ - dependentCats <\\> funCats - - funCats = tracePrt "fun cats" prt $ - nubsort [ cat | Rule _ (cat :@ _, decls) _ <- rules, - not (null decls) ] - - dependentCats = tracePrt "dep cats" prt $ - nubsort [ cat | Rule _ (cat :@ [], []) _ <- rules ] - - ----------------------------------------------------------------------- --- utilities - --- mergeing categories -mergeCats :: String -> String -> String -> Cat -> Cat -> Cat -mergeCats before middle after (IC cat) (IC arg) - = IC (before ++ cat ++ middle ++ arg ++ after) - -mergeFun, mergeArg :: Cat -> Cat -> Cat -mergeFun = mergeCats "{" ":" "}" -mergeArg = mergeCats "" "" "" - - diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs deleted file mode 100644 index c32812eb2..000000000 --- a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs +++ /dev/null @@ -1,34 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- All different conversions from GFC to MCFG ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertGFCtoMCFG - (convertGrammar) where - -import GF.Canon.GFC (CanonGrammar) -import GF.OldParsing.GrammarTypes -import GF.Infra.Ident (Ident(..)) -import GF.Infra.Option -import GF.System.Tracing - -import qualified GF.OldParsing.ConvertGFCtoMCFG.Old as Old -import qualified GF.OldParsing.ConvertGFCtoMCFG.Nondet as Nondet -import qualified GF.OldParsing.ConvertGFCtoMCFG.Strict as Strict -import qualified GF.OldParsing.ConvertGFCtoMCFG.Coercions as Coerce - -convertGrammar :: String -> (CanonGrammar, Ident) -> MCFGrammar -convertGrammar "nondet" = Coerce.addCoercions . Nondet.convertGrammar -convertGrammar "strict" = Strict.convertGrammar -convertGrammar "old" = Old.convertGrammar - diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs deleted file mode 100644 index 3ed6a3f48..000000000 --- a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs +++ /dev/null @@ -1,71 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Coercions --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:54 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Adding coercion functions to a MCFG if necessary. ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertGFCtoMCFG.Coercions (addCoercions) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import qualified GF.Infra.Ident as Ident -import GF.OldParsing.Utilities -import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) -import GF.Data.SortedList -import Data.List (groupBy) -- , transpose) - ----------------------------------------------------------------------- - -addCoercions :: MCFGrammar -> MCFGrammar -addCoercions rules = coercions ++ rules - where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | - Rule head args lins _ <- rules, - let lbls = [ lbl | Lin lbl _ <- lins ] ] - allHeadSet = nubsort allHeads - allArgSet = union allArgs <\\> map fst allHeadSet - coercions = tracePrt "#coercions total" (prt . length) $ - concat $ - tracePrt "#coercions per cat" (prtList . map length) $ - combineCoercions - (groupBy sameCatFst allHeadSet) - (groupBy sameCat allArgSet) - sameCatFst a b = sameCat (fst a) (fst b) - - -combineCoercions [] _ = [] -combineCoercions _ [] = [] -combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) - = case compare (mainCat $ fst $ head heads) (mainCat $ head args) of - LT -> combineCoercions allHeads allArgs' - GT -> combineCoercions allHeads' allArgs - EQ -> makeCoercion heads args : combineCoercions allHeads allArgs - - -makeCoercion heads args = [ Rule arg [head] lins coercionName | - (head@(MCFCat _ headCns), lbls) <- heads, - let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], - arg@(MCFCat _ argCns) <- args, - argCns `subset` headCns ] - - -coercionName = Ident.IW - -mainCat (MCFCat c _) = c - -sameCat mc1 mc2 = mainCat mc1 == mainCat mc2 - - diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs deleted file mode 100644 index 7727aa15f..000000000 --- a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs +++ /dev/null @@ -1,281 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Nondet --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Converting GFC grammars to MCFG grammars, nondeterministically. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertGFCtoMCFG.Nondet (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import Control.Monad -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.Look -import GF.Data.Operations -import qualified GF.Infra.Modules as M -import GF.Canon.CMacros (defLinType) -import GF.Canon.MkGFC (grammar2canon) -import GF.OldParsing.Utilities -import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..)) -import GF.Data.SortedList --- import Maybe (listToMaybe) -import Data.List (groupBy) -- , transpose) - -import GF.Data.BacktrackM - ----------------------------------------------------------------------- - -type Env = (CanonGrammar, Ident) - -convertGrammar :: Env -- ^ the canonical grammar, together with the selected language - -> MCFGrammar -- ^ the resulting MCF grammar -convertGrammar gram = trace2 "language" (prt (snd gram)) $ - trace2 "modules" (prtSep " " modnames) $ - tracePrt "#mcf-rules total" (prt . length) $ - solutions conversion undefined - where Gr modules = grammar2canon (fst gram) - modnames = uncurry M.allExtends gram - conversion = member modules >>= convertModule - convertModule (Mod (MTCnc modname _) _ _ _ defs) - | modname `elem` modnames = member defs >>= convertDef gram - convertModule _ = failure - -convertDef :: Env -> Def -> CnvMonad MCFRule -convertDef env (CncDFun fun (CIQ _ cat) args term _) - | trace2 "converting function" (prt fun) True - = do let iCat : iArgs = map initialMCat (cat : map catOfArg args) - writeState (iCat, iArgs, []) - convertTerm env cat term - (newCat, newArgs, linRec) <- readState - let newTerm = map (instLin newArgs) linRec - return (Rule newCat newArgs newTerm fun) -convertDef _ _ = failure - -instLin newArgs (Lin lbl lin) = Lin lbl (map instSym lin) - where instSym = mapSymbol instCat id - instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg) - -convertTerm :: Env -> Cat -> Term -> CnvMonad () -convertTerm env cat term = do rterm <- simplTerm env term - let ctype = lookupCType env cat - reduceT env ctype rterm emptyPath - ------------------------------------------------------------- - -type CnvMonad a = BacktrackM CMRule a - -type CMRule = (MCFCat, [MCFCat], LinRec) -type LinRec = [Lin Cat Path Tokn] - -initialMCat :: Cat -> MCFCat -initialMCat cat = MCFCat cat [] - ----------------------------------------------------------------------- - -simplTerm :: Env -> Term -> CnvMonad STerm -simplTerm env = simplifyTerm - where - simplifyTerm :: Term -> CnvMonad STerm - simplifyTerm (Arg (A cat nr)) = return (SArg (fromInteger nr) cat emptyPath) - simplifyTerm (Par con terms) = liftM (SCon con) $ mapM simplifyTerm terms - simplifyTerm (R record) = liftM SRec $ mapM simplifyAssign record - simplifyTerm (P term lbl) = liftM (+. lbl) $ simplifyTerm term - simplifyTerm (T ct table) = liftM STbl $ sequence $ concatMap simplifyCase table - simplifyTerm (V ct terms) - = liftM STbl $ sequence [ liftM ((,) pat) (simplifyTerm term) | - (pat, term) <- zip (groundTerms env ct) terms ] - simplifyTerm (S term sel) - = do sterm <- simplifyTerm term - ssel <- simplifyTerm sel - case sterm of - STbl table -> do (pat, val) <- member table - pat =?= ssel - return val - _ -> do sel' <- expandTerm env ssel - return (sterm +! sel') - simplifyTerm (FV terms) = liftM SVariants $ mapM simplifyTerm terms - simplifyTerm (term1 `C` term2) = liftM2 (SConcat) (simplifyTerm term1) (simplifyTerm term2) - simplifyTerm (K tokn) = return $ SToken tokn - simplifyTerm (E) = return $ SEmpty - simplifyTerm x = error $ "simplifyTerm: " ++ show x --- error constructors: --- (I CIdent) - from resource --- (LI Ident) - pattern variable --- (EInt Integer) - integer - - simplifyAssign :: Assign -> CnvMonad (Label, STerm) - simplifyAssign (Ass lbl term) = liftM ((,) lbl) $ simplifyTerm term - - simplifyCase :: Case -> [CnvMonad (STerm, STerm)] - simplifyCase (Cas pats term) = [ liftM2 (,) (simplifyPattern pat) (simplifyTerm term) | - pat <- pats ] - - simplifyPattern :: Patt -> CnvMonad STerm - simplifyPattern (PC con pats) = liftM (SCon con) $ mapM simplifyPattern pats - simplifyPattern (PW) = return SWildcard - simplifyPattern (PR record) = do record' <- mapM simplifyPattAssign record - case filter (\row -> snd row /= SWildcard) record' of - [] -> return SWildcard - record'' -> return (SRec record') - simplifyPattern x = error $ "simplifyPattern: " ++ show x --- error constructors: --- (PV Ident) - pattern variable - - simplifyPattAssign :: PattAssign -> CnvMonad (Label, STerm) - simplifyPattAssign (PAss lbl pat) = liftM ((,) lbl) $ simplifyPattern pat - - ------------------------------------------------------------- --- reducing simplified terms, collecting mcf rules - -reduceT :: Env -> CType -> STerm -> Path -> CnvMonad () -reduceT env = reduce - where - reduce :: CType -> STerm -> Path -> CnvMonad () - reduce TStr term path = updateLin (path, term) - reduce (Cn _) term path - = do pat <- expandTerm env term - updateHead (path, pat) - reduce ctype (SVariants terms) path - = do term <- member terms - reduce ctype term path - reduce (RecType rtype) term path - = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) | - Lbg lbl ctype <- rtype ] - reduce (Table _ ctype) (STbl table) path - = sequence_ [ reduce ctype term (path ++! pat) | - (pat, term) <- table ] - reduce (Table ptype vtype) arg@(SArg _ _ _) path - = sequence_ [ reduce vtype (arg +! pat) (path ++! pat) | - pat <- groundTerms env ptype ] - reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++ - ")\n term = (" ++ show term ++ - ")\n path = (" ++ show path ++ ")\n") - - ------------------------------------------------------------- --- expanding a term to ground terms - -expandTerm :: Env -> STerm -> CnvMonad STerm -expandTerm env arg@(SArg _ _ _) - = do pat <- member $ groundTerms env $ cTypeForArg env arg - pat =?= arg - return pat -expandTerm env (SCon con terms) = liftM (SCon con) $ mapM (expandTerm env) terms -expandTerm env (SRec record) = liftM SRec $ mapM (expandAssign env) record -expandTerm env (SVariants terms) = member terms >>= expandTerm env -expandTerm env term = error $ "expandTerm: " ++ show term - -expandAssign :: Env -> (Label, STerm) -> CnvMonad (Label, STerm) -expandAssign env (lbl, term) = liftM ((,) lbl) $ expandTerm env term - ------------------------------------------------------------- --- unification of patterns and selection terms - -(=?=) :: STerm -> STerm -> CnvMonad () -SWildcard =?= _ = return () -SRec precord =?= arg@(SArg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | - (lbl, pat) <- precord ] -pat =?= SArg arg _ path = updateArg arg (path, pat) -SCon con pats =?= SCon con' terms = do guard (con==con' && length pats==length terms) - sequence_ $ zipWith (=?=) pats terms -SRec precord =?= SRec record = sequence_ [ maybe mzero (pat =?=) mterm | - (lbl, pat) <- precord, - let mterm = lookup lbl record ] -pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term - - ------------------------------------------------------------- --- updating the mcf rule - -updateArg :: Int -> Constraint -> CnvMonad () -updateArg arg cn - = do (head, args, lins) <- readState - args' <- updateNth (addToMCFCat cn) arg args - writeState (head, args', lins) - -updateHead :: Constraint -> CnvMonad () -updateHead cn - = do (head, args, lins) <- readState - head' <- addToMCFCat cn head - writeState (head', args, lins) - -updateLin :: Constraint -> CnvMonad () -updateLin (path, term) - = do let newLins = term2lins term - (head, args, lins) <- readState - let lins' = lins ++ map (Lin path) newLins - writeState (head, args, lins') - -term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]] -term2lins (SArg arg cat path) = return [Cat (cat, path, arg)] -term2lins (SToken str) = return [Tok str] -term2lins (SConcat t1 t2) = liftM2 (++) (term2lins t1) (term2lins t2) -term2lins (SEmpty) = return [] -term2lins (SVariants terms) = terms >>= term2lins -term2lins term = error $ "term2lins: " ++ show term - -addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat -addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat cat) $ addConstraint cn cns - -addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] -addConstraint cn0 (cn : cns) - | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) - | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> - return (cn : cns) -addConstraint cn0 cns = return (cn0 : cns) - - ----------------------------------------------------------------------- --- utilities - -updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a] -updateNth update 0 (a : as) = liftM (:as) (update a) -updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as) - -catOfArg (A aCat _) = aCat -catOfArg (AB aCat _ _) = aCat - -lookupCType :: Env -> Cat -> CType -lookupCType env cat = errVal defLinType $ - lookupLincat (fst env) (CIQ (snd env) cat) - -groundTerms :: Env -> CType -> [STerm] -groundTerms env ctype = err error (map term2spattern) $ - allParamValues (fst env) ctype - -cTypeForArg :: Env -> STerm -> CType -cTypeForArg env (SArg nr cat (Path path)) - = follow path $ lookupCType env cat - where follow [] ctype = ctype - follow (Right pat : path) (Table _ ctype) = follow path ctype - follow (Left lbl : path) (RecType rec) - = case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of - [ctype] -> follow path ctype - err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ - " results in " ++ show err - -term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ] -term2spattern (Par con terms) = SCon con $ map term2spattern terms - diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs deleted file mode 100644 index 8b9b4a9ec..000000000 --- a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs +++ /dev/null @@ -1,277 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Old --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Converting GFC grammars to MCFG grammars. (Old variant) --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertGFCtoMCFG.Old (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm ---import PrintGFC -import qualified GF.Grammar.PrGrammar as PG - -import Control.Monad (liftM, liftM2, guard) --- import Maybe (listToMaybe) -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.Look -import GF.Data.Operations -import qualified GF.Infra.Modules as M -import GF.Canon.CMacros (defLinType) -import GF.Canon.MkGFC (grammar2canon) -import GF.OldParsing.Utilities -import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) -import GF.Data.SortedList (nubsort, groupPairs) -import Data.Maybe (listToMaybe) -import Data.List (groupBy, transpose) - ----------------------------------------------------------------------- --- old style types - -data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show) -type XMCFLabel = XPath - -cnvXMCFCat :: XMCFCat -> MCFCat -cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) | - (path, term) <- constrs ] - -cnvXMCFLabel :: XMCFLabel -> MCFLabel -cnvXMCFLabel = cnvXPath - -cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn -cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $ - map (mapSymbol cnvSym id) lin - where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr) - --- Term -> STerm - -cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ] -cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) | - Cas pats term <- tbl, pat <- pats ] -cnvTerm (Par con terms) = SCon con $ map cnvTerm terms -cnvTerm term - | isArgPath term = cnvArgPath term - -cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ] -cnvPattern (PC con pats) = SCon con $ map cnvPattern pats -cnvPattern (PW) = SWildcard - -isArgPath (Arg _) = True -isArgPath (P _ _) = True -isArgPath (S _ _) = True -isArgPath _ = False - -cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath -cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl -cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel - --- old style paths - -newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show) - -cnvXPath :: XPath -> Path -cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path)) - -emptyXPath :: XPath -emptyXPath = XPath [] - -(++..) :: XPath -> Label -> XPath -XPath path ++.. lbl = XPath (Left lbl : path) - -(++!!) :: XPath -> Term -> XPath -XPath path ++!! sel = XPath (Right sel : path) - ----------------------------------------------------------------------- - --- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis -convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar -convertGrammar (gram, lng) = trace2 "language" (prt lng) $ - trace2 "modules" (prtSep " " modnames) $ - trace2 "#lin-terms" (prt (length cncdefs)) $ - tracePrt "#mcf-rules total" (prt.length) $ - concat $ - tracePrt "#mcf-rules per fun" - (\rs -> concat [" "++show n++"="++show (length r) | - (n, r) <- zip [1..] rs]) $ - map (convertDef gram lng) cncdefs - where Gr mods = grammar2canon gram - cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods, - modname `elem` modnames, - def@(CncDFun _ _ _ _ _) <- defs ] - modnames = M.allExtends gram lng - - -convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule] -convertDef gram lng (CncDFun fun (CIQ _ cat) args term _) - = [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun | - let ctype = lookupCType gram lng cat, - instArgs <- mapM (enumerateInsts gram lng) args, - let instTerm = substitutePaths gram lng instArgs term, - newCat <- emcfCat gram lng cat instTerm, - newArgs <- mapM (extractArg gram lng instArgs) args, - let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm - ] - - --- gammalt skräp: --- mergeArgs = zipWith mergeRec --- mergeRec (R r1) (R r2) = R (r1 ++ r2) - -extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat] -extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr) - - -emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat] -emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat) - - -extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (E) = [[]] - convertLin (K tok) = [[Tok tok]] - convertLin (FV terms) = concatMap convertLin terms - convertLin term = map (return . Cat) $ flattenTerm emptyXPath term - flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)] - flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term - flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term - flattenTerm path (FV terms) = concatMap (flattenTerm path) terms - flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term - - -enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term] -enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat) - where enumerate path (TStr) = [ path ] - enumerate path (Cn con) = okError $ lookupParamValues gram con - enumerate path (RecType r) - = map R $ sequence [ map (lbl `Ass`) $ - enumerate (path `P` lbl) ctype | - lbl `Lbg` ctype <- r ] - enumerate path (Table s t) - = map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $ - enumerate (path `S` sel) t | - sel <- enumerate (error "enumerate") s ] - - - -termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))] -termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ] -termPaths gr l (RecType rtype) (R record) - = [ (path ++.. lbl, value) | - lbl `Ass` term <- record, - let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l (Table _ ctype) (T _ table) - = [ (path ++!! pattern2term pat, value) | - pats `Cas` term <- table, pat <- pats, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l (Table _ ctype) (V ptype table) - = [ (path ++!! pat, value) | - (pat, term) <- zip (okError $ allParamValues gr ptype) table, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l ctype (FV terms) - = concatMap (termPaths gr l ctype) terms -termPaths gr l (Cn pc) term = [ (emptyXPath, (Cn pc, term)) ] - -{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): -{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} -[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] --} - -parPaths :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]] -parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths) - where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ] - -strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)] -strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ] - - --- Substitute each instantiated parameter path for its instantiation -substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term -substitutePaths gr l arguments trm = subst trm - where subst (con `Par` terms) = con `Par` map subst terms - subst (R record) = R $ map substAss record - subst (term `P` lbl) = subst term `evalP` lbl - subst (T ptype table) = T ptype $ map substCas table - subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term | - (pat, term) <- zip (okError $ allParamValues gr ptype) table ] - subst (term `S` select) = subst term `evalS` subst select - subst (term `C` term') = subst term `C` subst term' - subst (FV terms) = evalFV $ map subst terms - subst (Arg (A _ arg)) = arguments !!! arg - subst term = term - - substAss (l `Ass` term) = l `Ass` subst term - substCas (p `Cas` term) = p `Cas` subst term - - -evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record - where errStr = "evalP: " ++ prt (R record `P` lbl) -evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ] -evalP term lbl = term `P` lbl - -evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl -evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ] -evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ] -evalS term sel = term `S` sel - -evalFV terms0 = case nubsort (concatMap flattenFV terms0) of - [term] -> term - terms -> FV terms - where flattenFV (FV ts) = ts - flattenFV t = [t] - - ----------------------------------------------------------------------- --- utilities - --- lookup a CType for an Ident -lookupCType :: CanonGrammar -> Ident -> Ident -> CType -lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c) - --- lookup a label in a (record / record ctype / table) -lookupAssign :: Label -> [Assign] -> Maybe Term -lookupLabelling :: Label -> [Labelling] -> Maybe CType -lookupCase :: Term -> [Case] -> Maybe Term - -lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ] -lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] -lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ] - -matchesPats :: Term -> [Patt] -> Bool -matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ] - --- converting between patterns and terms -pattern2term :: Patt -> Term -term2pattern :: Term -> Patt - -pattern2term (con `PC` patterns) = con `Par` map pattern2term patterns -pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern | - lbl `PAss` pattern <- record ] - -term2pattern (con `Par` terms) = con `PC` map term2pattern terms -term2pattern (R record) = PR [ lbl `PAss` term2pattern term | - lbl `Ass` term <- record ] - --- list lookup for Integers instead of Ints -(!!!) :: [a] -> Integer -> a -xs !!! n = xs !! fromInteger n diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs deleted file mode 100644 index d088bdebc..000000000 --- a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs +++ /dev/null @@ -1,189 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Strict --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Converting GFC grammars to MCFG grammars, nondeterministically. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertGFCtoMCFG.Strict (convertGrammar) where - -import GF.System.Tracing --- import IOExts (unsafePerformIO) -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import Control.Monad -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.Look -import GF.Data.Operations -import qualified GF.Infra.Modules as M -import GF.Canon.CMacros (defLinType) -import GF.Canon.MkGFC (grammar2canon) -import GF.OldParsing.Utilities -import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..)) -import GF.Data.SortedList --- import Maybe (listToMaybe) -import Data.List (groupBy) -- , transpose) - -import GF.Data.BacktrackM - ----------------------------------------------------------------------- - -type Env = (CanonGrammar, Ident) - -convertGrammar :: Env -- ^ the canonical grammar, together with the selected language - -> MCFGrammar -- ^ the resulting MCF grammar -convertGrammar gram = trace2 "language" (prt (snd gram)) $ - trace2 "modules" (prtSep " " modnames) $ - tracePrt "#mcf-rules total" (prt . length) $ - solutions conversion undefined - where Gr modules = grammar2canon (fst gram) - modnames = uncurry M.allExtends gram - conversion = member modules >>= convertModule - convertModule (Mod (MTCnc modname _) _ _ _ defs) - | modname `elem` modnames = member defs >>= convertDef gram - convertModule _ = failure - -convertDef :: Env -> Def -> CnvMonad MCFRule -convertDef env (CncDFun fun (CIQ _ cat) args term _) - | trace2 "converting function" (prt fun) True - = do let ctype = lookupCType env cat - instArgs <- mapM (enumerateArg env) args - let instTerm = substitutePaths env instArgs term - newCat <- emcfCat env cat instTerm - newArgs <- mapM (extractArg env instArgs) args - let newTerm = strPaths env ctype instTerm >>= extractLin newArgs - return (Rule newCat newArgs newTerm fun) -convertDef _ _ = failure - ------------------------------------------------------------- - -type CnvMonad a = BacktrackM () a - ----------------------------------------------------------------------- --- strict conversion - -extractArg :: Env -> [STerm] -> ArgVar -> CnvMonad MCFCat -extractArg env args (A cat nr) = emcfCat env cat (args !! fromInteger nr) - -emcfCat :: Env -> Cat -> STerm -> CnvMonad MCFCat -emcfCat env cat term = member $ map (MCFCat cat) $ parPaths env (lookupCType env cat) term - -enumerateArg :: Env -> ArgVar -> CnvMonad STerm -enumerateArg env (A cat nr) = let ctype = lookupCType env cat - in enumerate (SArg (fromInteger nr) cat emptyPath) ctype - where enumerate arg (TStr) = return arg - enumerate arg ctype@(Cn _) = member $ groundTerms env ctype - enumerate arg (RecType rtype) - = liftM SRec $ sequence [ liftM ((,) lbl) $ - enumerate (arg +. lbl) ctype | - lbl `Lbg` ctype <- rtype ] - enumerate arg (Table stype ctype) - = do state <- readState - liftM STbl $ sequence [ liftM ((,) sel) $ - enumerate (arg +! sel) ctype | - sel <- solutions (enumerate err stype) state ] - where err = error "enumerate: parameter type should not be string" - --- Substitute each instantiated parameter path for its instantiation -substitutePaths :: Env -> [STerm] -> Term -> STerm -substitutePaths env arguments trm = subst trm - where subst (con `Par` terms) = con `SCon` map subst terms - subst (R record) = SRec [ (lbl, subst term) | lbl `Ass` term <- record ] - subst (term `P` lbl) = subst term +. lbl - subst (T ptype table) = STbl [ (pattern2sterm pat, subst term) | - pats `Cas` term <- table, pat <- pats ] - subst (V ptype table) = STbl [ (pat, subst term) | - (pat, term) <- zip (groundTerms env ptype) table ] - subst (term `S` select) = subst term +! subst select - subst (term `C` term') = subst term `SConcat` subst term' - subst (K str) = SToken str - subst (E) = SEmpty - subst (FV terms) = evalFV $ map subst terms - subst (Arg (A _ arg)) = arguments !! fromInteger arg - - -termPaths :: Env -> CType -> STerm -> [(Path, (CType, STerm))] -termPaths env (TStr) term = [ (emptyPath, (TStr, term)) ] -termPaths env (RecType rtype) (SRec record) - = [ (path ++. lbl, value) | - (lbl, term) <- record, - let ctype = lookupLabelling lbl rtype, - (path, value) <- termPaths env ctype term ] -termPaths env (Table _ ctype) (STbl table) - = [ (path ++! pat, value) | - (pat, term) <- table, - (path, value) <- termPaths env ctype term ] -termPaths env ctype (SVariants terms) - = terms >>= termPaths env ctype -termPaths env (Cn pc) term = [ (emptyPath, (Cn pc, term)) ] - -{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): -{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} -[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] --} - -parPaths :: Env -> CType -> STerm -> [[(Path, STerm)]] -parPaths env ctype term = mapM (uncurry (map . (,))) (groupPairs paths) - where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths env ctype term ] - -strPaths :: Env -> CType -> STerm -> [(Path, STerm)] -strPaths env ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths env ctype term ] - -extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 `SConcat` t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (SEmpty) = [[]] - convertLin (SToken tok) = [[Tok tok]] - convertLin (SVariants terms) = concatMap convertLin terms - convertLin (SArg nr _ path) = [[Cat (args !! nr, path, nr)]] - -evalFV terms0 = case nubsort (concatMap flattenFV terms0) of - [term] -> term - terms -> SVariants terms - where flattenFV (SVariants ts) = ts - flattenFV t = [t] - ----------------------------------------------------------------------- --- utilities - -lookupCType :: Env -> Cat -> CType -lookupCType env cat = errVal defLinType $ - lookupLincat (fst env) (CIQ (snd env) cat) - -lookupLabelling :: Label -> [Labelling] -> CType -lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of - [ctyp] -> ctyp - err -> error $ "lookupLabelling:" ++ show err - -groundTerms :: Env -> CType -> [STerm] -groundTerms env ctype = err error (map term2spattern) $ - allParamValues (fst env) ctype - -term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ] -term2spattern (Par con terms) = SCon con $ map term2spattern terms - -pattern2sterm :: Patt -> STerm -pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns -pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) | - lbl `PAss` pattern <- record ] - diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs b/src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs deleted file mode 100644 index 69a8b13c3..000000000 --- a/src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs +++ /dev/null @@ -1,122 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Converting GFC to SimpleGFC --- --- the conversion might fail if the GFC grammar has dependent or higher-order types ------------------------------------------------------------------------------ - -module GF.OldParsing.ConvertGFCtoSimple where - -import qualified GF.Canon.AbsGFC as A -import qualified GF.Infra.Ident as I -import GF.OldParsing.SimpleGFC - -import GF.Canon.GFC -import GF.Canon.MkGFC (grammar2canon) -import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat) -import qualified GF.Canon.CMacros as CMacros (defLinType) -import GF.Data.Operations (err, errVal) -import qualified GF.Infra.Modules as M - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - ----------------------------------------------------------------------- - -type Env = (CanonGrammar, I.Ident) - -convertGrammar :: Env -> Grammar -convertGrammar gram = trace2 "language" (show (snd gram)) $ - tracePrt "#simple-rules total" (show . length) $ - [ convertAbsFun gram fun typing | - A.Mod (A.MTAbs modname) _ _ _ defs <- modules, - A.AbsDFun fun typing _ <- defs ] - where A.Gr modules = grammar2canon (fst gram) - -convertAbsFun :: Env -> I.Ident -> A.Exp -> Rule -convertAbsFun gram fun aTyping - = -- trace2 "absFun" (show fun) $ - Rule fun sTyping sTerm - where sTyping = convertTyping [] aTyping - sTerm = do lin <- lookupLin gram fun - return (convertTerm gram lin, convertCType gram cType) - cType = lookupCType gram sTyping - -convertTyping :: [Decl] -> A.Exp -> Typing --- convertTyping env tp | trace2 "typing" (prt env ++ " / " ++ prt tp) False = undefined -convertTyping env (A.EProd x a b) - = convertTyping ((x ::: convertType [] a) : env) b -convertTyping env a = (convertType [] a, reverse env) - -convertType :: [Atom] -> A.Exp -> Type --- convertType args tp | trace2 "type" (prt args ++ " / " ++ prt tp) False = undefined -convertType args (A.EApp a (A.EAtom at)) = convertType (convertAtom at : args) a -convertType args (A.EAtom at) = convertCat at :@ args - -convertAtom :: A.Atom -> Atom -convertAtom (A.AC con) = ACon con -convertAtom (A.AV var) = AVar var - -convertCat :: A.Atom -> Cat -convertCat (A.AC (A.CIQ _ cat)) = cat -convertCat at = error $ "convertCat: " ++ show at - -convertCType :: Env -> A.CType -> CType -convertCType gram (A.RecType rec) - = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ] -convertCType gram (A.Table ptype vtype) - = TblT (convertCType gram ptype) (convertCType gram vtype) -convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct -convertCType gram (A.TStr) = StrT -convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor" - -convertTerm :: Env -> A.Term -> Term -convertTerm gram (A.Arg arg) = convertArgVar arg -convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms -convertTerm gram (A.LI var) = Var var -convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ] -convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl -convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) | - (pat, term) <- zip (groundTerms gram ctype) terms ] -convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) | - A.Cas pats term <- tbl, pat <- pats ] -convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel -convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2 -convertTerm gram (A.FV terms) = Variants (map (convertTerm gram) terms) -convertTerm gram (A.K tok) = Token tok -convertTerm gram (A.E) = Empty -convertTerm gram (A.I con) = error "convertTerm: cannot handle 'I' constructor" -convertTerm gram (A.EInt int) = error "convertTerm: cannot handle 'EInt' constructor" - -convertArgVar :: A.ArgVar -> Term -convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath -convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath - -convertPatt (A.PC con pats) = con :^ map convertPatt pats -convertPatt (A.PV x) = Var x -convertPatt (A.PW) = Wildcard -convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ] -convertPatt (A.PI n) = error "convertPatt: cannot handle 'PI' constructor" - ----------------------------------------------------------------------- - -lookupLin gram fun = err fail Just $ - Look.lookupLin (fst gram) (A.CIQ (snd gram) fun) - ---lookupCType :: Env -> Typing -> CType -lookupCType env (cat :@ _, _) = errVal CMacros.defLinType $ - Look.lookupLincat (fst env) (A.CIQ (snd env) cat) - -groundTerms :: Env -> A.CType -> [A.Term] -groundTerms gram ctype = err error id $ - Look.allParamValues (fst gram) ctype - diff --git a/src-3.0/GF/OldParsing/ConvertGrammar.hs b/src-3.0/GF/OldParsing/ConvertGrammar.hs deleted file mode 100644 index 0dcd90770..000000000 --- a/src-3.0/GF/OldParsing/ConvertGrammar.hs +++ /dev/null @@ -1,44 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGrammar --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:45 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- All (?) grammar conversions which are used in GF ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertGrammar - (pInfo, emptyPInfo, - module GF.OldParsing.GrammarTypes - ) where - -import GF.Canon.GFC (CanonGrammar) -import GF.Canon.MkGFC (grammar2canon) -import GF.OldParsing.GrammarTypes -import GF.Infra.Ident (Ident(..)) -import GF.Infra.Option -import GF.System.Tracing - --- import qualified GF.OldParsing.FiniteTypes.Calc as Fin -import qualified GF.OldParsing.ConvertGFCtoMCFG as G2M -import qualified GF.OldParsing.ConvertMCFGtoCFG as M2C -import qualified GF.OldParsing.MCFGrammar as MCFG -import qualified GF.OldParsing.CFGrammar as CFG - -pInfo :: Options -> CanonGrammar -> Ident -> PInfo -pInfo opts canon lng = PInfo mcfg cfg mcfp cfp - where mcfg = G2M.convertGrammar cnv (canon, lng) - cnv = maybe "nondet" id $ getOptVal opts gfcConversion - cfg = M2C.convertGrammar mcfg - mcfp = MCFG.pInfo mcfg - cfp = CFG.pInfo cfg - -emptyPInfo :: PInfo -emptyPInfo = PInfo [] [] (MCFG.pInfo []) (CFG.pInfo []) - diff --git a/src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs b/src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs deleted file mode 100644 index 58d141166..000000000 --- a/src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs +++ /dev/null @@ -1,52 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertMCFGtoCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:46 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Converting MCFG grammars to (possibly overgenerating) CFG ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertMCFGtoCFG - (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser - -import Control.Monad -import GF.OldParsing.Utilities -import qualified GF.OldParsing.MCFGrammar as MCFG -import qualified GF.OldParsing.CFGrammar as CFG -import GF.OldParsing.GrammarTypes - -convertGrammar :: MCFGrammar -> CFGrammar -convertGrammar gram = tracePrt "#cf-rules" (prt.length) $ - concatMap convertRule gram - -convertRule :: MCFRule -> [CFRule] -convertRule (MCFG.Rule cat args record name) - = [ CFG.Rule (CFCat cat lbl) rhs (CFName name profile) | - MCFG.Lin lbl lin <- record, - let rhs = map (mapSymbol convertArg id) lin, - let profile = map (argPlaces lin) [0 .. length args-1] - ] - -convertArg (cat, lbl, _arg) = CFCat cat lbl - -argPlaces lin arg = [ place | ((_cat, _lbl, arg'), place) <- - zip (filterCats lin) [0::Int ..], arg == arg' ] - -filterCats syms = [ cat | Cat cat <- syms ] - - - - - - - diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs deleted file mode 100644 index e111444f9..000000000 --- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs +++ /dev/null @@ -1,30 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/11 13:52:53 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- All different conversions from SimpleGFC to MCFG ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertSimpleToMCFG - (convertGrammar) where - -import qualified GF.OldParsing.SimpleGFC as S ---import GF.OldParsing.GrammarTypes - -import qualified GF.OldParsing.ConvertFiniteSimple as Fin -import qualified GF.OldParsing.ConvertSimpleToMCFG.Nondet as Nondet ---import qualified GF.OldParsing.ConvertSimpleToMCFG.Strict as Strict -import qualified GF.OldParsing.ConvertSimpleToMCFG.Coercions as Coerce - ---convertGrammar :: String -> S.Grammar -> MCFGrammar -convertGrammar ('f':'i':'n':'-':cnv) = convertGrammar cnv . Fin.convertGrammar -convertGrammar "nondet" = Coerce.addCoercions . Nondet.convertGrammar ---convertGrammar "strict" = Strict.convertGrammar - diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs deleted file mode 100644 index adc42115a..000000000 --- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs +++ /dev/null @@ -1,70 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:57 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Adding coercion functions to a MCFG if necessary. ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertSimpleToMCFG.Coercions (addCoercions) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import qualified GF.Infra.Ident as Ident -import GF.OldParsing.Utilities ---import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) -import GF.Data.SortedList -import Data.List (groupBy) -- , transpose) - ----------------------------------------------------------------------- - ---addCoercions :: MCFGrammar -> MCFGrammar -addCoercions rules = coercions ++ rules - where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | - Rule head args lins _ <- rules, - let lbls = [ lbl | Lin lbl _ <- lins ] ] - allHeadSet = nubsort allHeads - allArgSet = union allArgs <\\> map fst allHeadSet - coercions = tracePrt "#coercions total" (prt . length) $ - concat $ - tracePrt "#coercions per cat" (prtList . map length) $ - combineCoercions - (groupBy sameCatFst allHeadSet) - (groupBy sameCat allArgSet) - sameCatFst a b = sameCat (fst a) (fst b) - - -combineCoercions [] _ = [] -combineCoercions _ [] = [] -combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) - = case compare (mainCat $ fst $ head heads) (mainCat $ head args) of - LT -> combineCoercions allHeads allArgs' - GT -> combineCoercions allHeads' allArgs - EQ -> makeCoercion heads args : combineCoercions allHeads allArgs - - -makeCoercion heads args = [ Rule arg [head] lins coercionName | - head@((_, headCns), lbls) <- heads, - let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], - arg@(_, argCns) <- args, - argCns `subset` headCns ] - - -coercionName = Ident.IW - -mainCat (c, _) = c - -sameCat mc1 mc2 = mainCat mc1 == mainCat mc2 - - diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs deleted file mode 100644 index 6627c5f2e..000000000 --- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs +++ /dev/null @@ -1,245 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:58 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertSimpleToMCFG.Nondet (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm --- import PrintGFC --- import qualified PrGrammar as PG - -import Control.Monad --- import Ident (Ident(..)) -import qualified GF.Canon.AbsGFC as AbsGFC --- import GFC -import GF.Canon.Look -import GF.Data.Operations --- import qualified Modules as M -import GF.Canon.CMacros (defLinType) --- import MkGFC (grammar2canon) -import GF.OldParsing.Utilities --- import GF.OldParsing.GrammarTypes -import GF.Data.SortedList -import qualified GF.OldParsing.MCFGrammar as MCF (Grammar, Rule(..), Lin(..)) -import GF.OldParsing.SimpleGFC --- import Maybe (listToMaybe) -import Data.List (groupBy) -- , transpose) - -import GF.Data.BacktrackM - ----------------------------------------------------------------------- - ---convertGrammar :: Grammar -> MCF.Grammar -convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $ - solutions conversion rules undefined - where conversion = member rules >>= convertRule - ---convertRule :: Rule -> CnvMonad MCF.Rule -convertRule (Rule fun (cat :@ _, decls) (Just (term, ctype))) - = do let args = [ arg | _ ::: (arg :@ _) <- decls ] - writeState (initialMCat cat, map initialMCat args, []) - convertTerm cat term - (newCat, newArgs, linRec) <- readState - let newTerm = map (instLin newArgs) linRec - return (MCF.Rule newCat newArgs newTerm fun) -convertRule _ = failure - -instLin newArgs (MCF.Lin lbl lin) = MCF.Lin lbl (map instSym lin) - where instSym = mapSymbol instCat id - instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg) - ---convertTerm :: Cat -> Term -> CnvMonad () -convertTerm cat term = do rterm <- simplifyTerm term - env <- readEnv - let ctype = lookupCType env cat - reduce ctype rterm emptyPath - ------------------------------------------------------------- - -{- -type CnvMonad a = BacktrackM Grammar CMRule a - -type CMRule = (MCFCat, [MCFCat], LinRec) -type LinRec = [Lin Cat Path Tokn] --} - ---initialMCat :: Cat -> MCFCat -initialMCat cat = (cat, []) --MCFCat cat [] - ----------------------------------------------------------------------- - ---simplifyTerm :: Term -> CnvMonad STerm -simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms -simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record -simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term -simplifyTerm (Tbl table) = Tbl $ mapM simplifyCase table -simplifyTerm (term :! sel) - = do sterm <- simplifyTerm term - ssel <- simplifyTerm sel - case sterm of - Tbl table -> do (pat, val) <- member table - pat =?= ssel - return val - _ -> do sel' <- expandTerm ssel - return (sterm +! sel') -simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms -simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2) -simplifyTerm term = return term --- error constructors: --- (I CIdent) - from resource --- (LI Ident) - pattern variable --- (EInt Integer) - integer - ---simplifyAssign :: Assign -> CnvMonad (Label, STerm) -simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term - ---simplifyCase :: Case -> [CnvMonad (STerm, STerm)] -simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) - - ------------------------------------------------------------- --- reducing simplified terms, collecting mcf rules - ---reduce :: CType -> STerm -> Path -> CnvMonad () -reduce StrT term path = updateLin (path, term) -reduce (ConT _) term path - = do pat <- expandTerm term - updateHead (path, pat) -reduce ctype (Variants terms) path - = do term <- member terms - reduce ctype term path -reduce (RecT rtype) term path - = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) | - (lbl, ctype) <- rtype ] -reduce (TblT _ ctype) (Tbl table) path - = sequence_ [ reduce ctype term (path ++! pat) | - (pat, term) <- table ] -reduce (TblT ptype vtype) arg@(Arg _ _ _) path - = do env <- readEnv - sequence_ [ reduce vtype (arg +! pat) (path ++! pat) | - pat <- groundTerms ptype ] -reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++ - ")\n term = (" ++ show term ++ - ")\n path = (" ++ show path ++ ")\n") - - ------------------------------------------------------------- --- expanding a term to ground terms - ---expandTerm :: STerm -> CnvMonad STerm -expandTerm arg@(Arg _ _ _) - = do env <- readEnv - pat <- member $ groundTerms $ cTypeForArg env arg - pat =?= arg - return pat -expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms -expandTerm (Rec record) = liftM Rec $ mapM expandAssign record -expandTerm (Variants terms) = member terms >>= expandTerm -expandTerm term = error $ "expandTerm: " ++ show term - ---expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) -expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term - ------------------------------------------------------------- --- unification of patterns and selection terms - ---(=?=) :: STerm -> STerm -> CnvMonad () -Wildcard =?= _ = return () -Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | - (lbl, pat) <- precord ] -pat =?= Arg arg _ path = updateArg arg (path, pat) -(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms) - sequence_ $ zipWith (=?=) pats terms -Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm | - (lbl, pat) <- precord, - let mterm = lookup lbl record ] -pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term - - ------------------------------------------------------------- --- updating the mcf rule - ---updateArg :: Int -> Constraint -> CnvMonad () -updateArg arg cn - = do (head, args, lins) <- readState - args' <- updateNth (addToMCFCat cn) arg args - writeState (head, args', lins) - ---updateHead :: Constraint -> CnvMonad () -updateHead cn - = do (head, args, lins) <- readState - head' <- addToMCFCat cn head - writeState (head', args, lins) - ---updateLin :: Constraint -> CnvMonad () -updateLin (path, term) - = do let newLins = term2lins term - (head, args, lins) <- readState - let lins' = lins ++ map (MCF.Lin path) newLins - writeState (head, args, lins') - ---term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]] -term2lins (Arg arg cat path) = return [Cat (cat, path, arg)] -term2lins (Token str) = return [Tok str] -term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2) -term2lins (Empty) = return [] -term2lins (Variants terms) = terms >>= term2lins -term2lins term = error $ "term2lins: " ++ show term - ---addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat -addToMCFCat cn ({-MCFCat-} cat, cns) = liftM ({-MCFCat-} (,) cat) $ addConstraint cn cns - ---addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] -addConstraint cn0 (cn : cns) - | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) - | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> - return (cn : cns) -addConstraint cn0 cns = return (cn0 : cns) - - ----------------------------------------------------------------------- --- utilities - -updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a] -updateNth update 0 (a : as) = liftM (:as) (update a) -updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as) - ---lookupCType :: GrammarEnv -> Cat -> CType -lookupCType env cat = errVal defLinType $ - lookupLincat (fst env) (AbsGFC.CIQ (snd env) cat) - ---groundTerms :: GrammarEnv -> CType -> [STerm] -groundTerms env ctype = err error (map term2spattern) $ - allParamValues (fst env) ctype - ---cTypeForArg :: GrammarEnv -> STerm -> CType -cTypeForArg env (Arg nr cat (Path path)) - = follow path $ lookupCType env cat - where follow [] ctype = ctype - follow (Right pat : path) (TblT _ ctype) = follow path ctype - follow (Left lbl : path) (RecT rec) - = case [ ctype | (lbl', ctype) <- rec, lbl == lbl' ] of - [ctype] -> follow path ctype - err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ - " results in " ++ show err - -term2spattern (AbsGFC.R rec) = Rec [ (lbl, term2spattern term) | - AbsGFC.Ass lbl term <- rec ] -term2spattern (AbsGFC.Con con terms) = con :^ map term2spattern terms - diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs deleted file mode 100644 index dd2ff0713..000000000 --- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs +++ /dev/null @@ -1,277 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ConvertGFCtoMCFG.Old --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:59 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Converting GFC grammars to MCFG grammars. (Old variant) --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. --- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertSimpleToMCFG.Old (convertGrammar) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm ---import PrintGFC -import qualified GF.Grammar.PrGrammar as PG - -import Control.Monad (liftM, liftM2, guard) --- import Maybe (listToMaybe) -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.Look -import GF.Data.Operations -import qualified GF.Infra.Modules as M -import GF.Canon.CMacros (defLinType) -import GF.Canon.MkGFC (grammar2canon) -import GF.OldParsing.Utilities -import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) -import GF.Data.SortedList (nubsort, groupPairs) -import Data.Maybe (listToMaybe) -import Data.List (groupBy, transpose) - ----------------------------------------------------------------------- --- old style types - -data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show) -type XMCFLabel = XPath - -cnvXMCFCat :: XMCFCat -> MCFCat -cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) | - (path, term) <- constrs ] - -cnvXMCFLabel :: XMCFLabel -> MCFLabel -cnvXMCFLabel = cnvXPath - -cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn -cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $ - map (mapSymbol cnvSym id) lin - where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr) - --- Term -> STerm - -cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ] -cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) | - Cas pats term <- tbl, pat <- pats ] -cnvTerm (Con con terms) = SCon con $ map cnvTerm terms -cnvTerm term - | isArgPath term = cnvArgPath term - -cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ] -cnvPattern (PC con pats) = SCon con $ map cnvPattern pats -cnvPattern (PW) = SWildcard - -isArgPath (Arg _) = True -isArgPath (P _ _) = True -isArgPath (S _ _) = True -isArgPath _ = False - -cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath -cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl -cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel - --- old style paths - -newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show) - -cnvXPath :: XPath -> Path -cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path)) - -emptyXPath :: XPath -emptyXPath = XPath [] - -(++..) :: XPath -> Label -> XPath -XPath path ++.. lbl = XPath (Left lbl : path) - -(++!!) :: XPath -> Term -> XPath -XPath path ++!! sel = XPath (Right sel : path) - ----------------------------------------------------------------------- - --- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis -convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar -convertGrammar (gram, lng) = trace2 "language" (prt lng) $ - trace2 "modules" (prtSep " " modnames) $ - trace2 "#lin-terms" (prt (length cncdefs)) $ - tracePrt "#mcf-rules total" (prt.length) $ - concat $ - tracePrt "#mcf-rules per fun" - (\rs -> concat [" "++show n++"="++show (length r) | - (n, r) <- zip [1..] rs]) $ - map (convertDef gram lng) cncdefs - where Gr mods = grammar2canon gram - cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods, - modname `elem` modnames, - def@(CncDFun _ _ _ _ _) <- defs ] - modnames = M.allExtends gram lng - - -convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule] -convertDef gram lng (CncDFun fun (CIQ _ cat) args term _) - = [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun | - let ctype = lookupCType gram lng cat, - instArgs <- mapM (enumerateInsts gram lng) args, - let instTerm = substitutePaths gram lng instArgs term, - newCat <- emcfCat gram lng cat instTerm, - newArgs <- mapM (extractArg gram lng instArgs) args, - let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm - ] - - --- gammalt skräp: --- mergeArgs = zipWith mergeRec --- mergeRec (R r1) (R r2) = R (r1 ++ r2) - -extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat] -extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr) - - -emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat] -emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat) - - -extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (E) = [[]] - convertLin (K tok) = [[Tok tok]] - convertLin (FV terms) = concatMap convertLin terms - convertLin term = map (return . Cat) $ flattenTerm emptyXPath term - flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)] - flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term - flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term - flattenTerm path (FV terms) = concatMap (flattenTerm path) terms - flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term - - -enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term] -enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat) - where enumerate path (TStr) = [ path ] - enumerate path (Cn con) = okError $ lookupParamValues gram con - enumerate path (RecType r) - = map R $ sequence [ map (lbl `Ass`) $ - enumerate (path `P` lbl) ctype | - lbl `Lbg` ctype <- r ] - enumerate path (Table s t) - = map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $ - enumerate (path `S` sel) t | - sel <- enumerate (error "enumerate") s ] - - - -termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))] -termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ] -termPaths gr l (RecType rtype) (R record) - = [ (path ++.. lbl, value) | - lbl `Ass` term <- record, - let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l (Table _ ctype) (T _ table) - = [ (path ++!! pattern2term pat, value) | - pats `Cas` term <- table, pat <- pats, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l (Table _ ctype) (V ptype table) - = [ (path ++!! pat, value) | - (pat, term) <- zip (okError $ allParamValues gr ptype) table, - (path, value) <- termPaths gr l ctype term ] -termPaths gr l ctype (FV terms) - = concatMap (termPaths gr l ctype) terms -termPaths gr l (Cn pc) term = [ (emptyXPath, (Cn pc, term)) ] - -{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): -{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} -[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] --} - -parPaths :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]] -parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths) - where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ] - -strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)] -strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ] - - --- Substitute each instantiated parameter path for its instantiation -substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term -substitutePaths gr l arguments trm = subst trm - where subst (con `Con` terms) = con `Con` map subst terms - subst (R record) = R $ map substAss record - subst (term `P` lbl) = subst term `evalP` lbl - subst (T ptype table) = T ptype $ map substCas table - subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term | - (pat, term) <- zip (okError $ allParamValues gr ptype) table ] - subst (term `S` select) = subst term `evalS` subst select - subst (term `C` term') = subst term `C` subst term' - subst (FV terms) = evalFV $ map subst terms - subst (Arg (A _ arg)) = arguments !!! arg - subst term = term - - substAss (l `Ass` term) = l `Ass` subst term - substCas (p `Cas` term) = p `Cas` subst term - - -evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record - where errStr = "evalP: " ++ prt (R record `P` lbl) -evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ] -evalP term lbl = term `P` lbl - -evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl -evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ] -evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ] -evalS term sel = term `S` sel - -evalFV terms0 = case nubsort (concatMap flattenFV terms0) of - [term] -> term - terms -> FV terms - where flattenFV (FV ts) = ts - flattenFV t = [t] - - ----------------------------------------------------------------------- --- utilities - --- lookup a CType for an Ident -lookupCType :: CanonGrammar -> Ident -> Ident -> CType -lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c) - --- lookup a label in a (record / record ctype / table) -lookupAssign :: Label -> [Assign] -> Maybe Term -lookupLabelling :: Label -> [Labelling] -> Maybe CType -lookupCase :: Term -> [Case] -> Maybe Term - -lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ] -lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] -lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ] - -matchesPats :: Term -> [Patt] -> Bool -matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ] - --- converting between patterns and terms -pattern2term :: Patt -> Term -term2pattern :: Term -> Patt - -pattern2term (con `PC` patterns) = con `Con` map pattern2term patterns -pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern | - lbl `PAss` pattern <- record ] - -term2pattern (con `Con` terms) = con `PC` map term2pattern terms -term2pattern (R record) = PR [ lbl `PAss` term2pattern term | - lbl `Ass` term <- record ] - --- list lookup for Integers instead of Ints -(!!!) :: [a] -> Integer -> a -xs !!! n = xs !! fromInteger n diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs deleted file mode 100644 index aa741518a..000000000 --- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs +++ /dev/null @@ -1,139 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Converting SimpleGFC grammars to MCFG grammars, deterministic. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. ------------------------------------------------------------------------------ - - -module GF.OldParsing.ConvertSimpleToMCFG.Strict (convertGrammar) where - -import GF.System.Tracing -import GF.Infra.Print - -import Control.Monad - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.SimpleGFC -import GF.Conversion.Types - -import GF.Data.BacktrackM - -{- -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC -import GF.Canon.GFC -import GF.Canon.Look -import GF.Data.Operations -import qualified GF.Infra.Modules as M -import GF.Canon.CMacros (defLinType) -import GF.Canon.MkGFC (grammar2canon) -import GF.OldParsing.Utilities -import GF.OldParsing.GrammarTypes -import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..)) -import GF.Data.SortedList --- import Maybe (listToMaybe) -import Data.List (groupBy) -- , transpose) - -import GF.Data.BacktrackM --} - ----------------------------------------------------------------------- - -convertGrammar :: SimpleGrammar -> MGrammar -convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $ - solutions conversion undefined - where conversion = member rules >>= convertRule - -convertRule :: SimpleRule -> CnvMonad MRule -convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) - = do let cat : args = map decl2cat (decl : decls) - args_ctypes = zip3 [0..] args ctypes - instArgs <- mapM enumerateArg args_ctypes - let instTerm = substitutePaths instArgs term - newCat <- extractMCat cat ctype instTerm - newArgs <- mapM (extractArg instArgs) args - let newLinRec = strPaths ctype instTerm >>= extractLin newArgs - lintype : lintypes = map (convertLinType emptyPath) (ctype : ctypes) - return $ Rule (Abs newCat newArgs fun) (Cnc lintype lintypes newLinRec) -convertRule _ = failure - ----------------------------------------------------------------------- - -type CnvMonad a = BacktrackM () a - ----------------------------------------------------------------------- --- strict conversion - ---extractArg :: [Term] -> (Int, Cat, LinType) -> CnvMonad MCat -extractArg args (nr, cat, ctype) = emcfCat cat ctype (args !! nr) - ---emcfCat :: Cat -> LinType -> Term -> CnvMonad MCat -extractMCat cat ctype term = map (MCat cat) $ parPaths ctype term - ---enumerateArg :: (Int, Cat, LinType) -> CnvMonad Term -enumerateArg (nr, cat, ctype) = enumerateTerms (Arg nr cat emptyPath) ctype - --- Substitute each instantiated parameter path for its instantiation -substitutePaths :: [Term] -> Term -> Term -substitutePaths arguments = subst - where subst (Arg nr _ path) = followPath path (arguments !! nr) - subst (con :^ terms) = con :^ map subst terms - subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ] - subst (term :. lbl) = subst term +. lbl - subst (Tbl table) = Tbl [ (pat, subst term) | - (pat, term) <- table ] - subst (term :! select) = subst term +! subst select - subst (term :++ term') = subst term ?++ subst term' - subst (Variants terms) = Variants $ map subst terms - subst term = term - - ---termPaths :: CType -> STerm -> [(Path, (CType, STerm))] -termPaths ctype (Variants terms) = terms >>= termPaths ctype -termPaths (StrT) term = [ (emptyPath, (StrT, term)) ] -termPaths (RecT rtype) (Rec record) - = [ (path ++. lbl, value) | - (lbl, term) <- record, - let Just ctype = lookup lbl rtype, - (path, value) <- termPaths ctype term ] -termPaths (TblT _ ctype) (Tbl table) - = [ (path ++! pat, value) | - (pat, term) <- table, - (path, value) <- termPaths ctype term ] -termPaths (ConT pc _) term = [ (emptyPath, (ConT pc, term)) ] - -{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): -{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} -[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] --} - ---parPaths :: CType -> STerm -> [[(Path, STerm)]] -parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ - nubsort [ (path, value) | - (path, (ConT _, value)) <- termPaths ctype term ] - ---strPaths :: CType -> STerm -> [(Path, STerm)] -strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ] - where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ] - ---extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn] -extractLin args (path, term) = map (Lin path) (convertLin term) - where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2) - convertLin (Empty) = [[]] - convertLin (Token tok) = [[Tok tok]] - convertLin (Variants terms) = concatMap convertLin terms - convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]] - diff --git a/src-3.0/GF/OldParsing/GCFG.hs b/src-3.0/GF/OldParsing/GCFG.hs deleted file mode 100644 index 33a710e5d..000000000 --- a/src-3.0/GF/OldParsing/GCFG.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/11 13:52:53 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Simplistic GFC format ------------------------------------------------------------------------------ - -module GF.OldParsing.GCFG where - -import GF.Printing.PrintParser - ----------------------------------------------------------------------- - -type Grammar c n l t = [Rule c n l t] -data Rule c n l t = Rule (Abstract c n) (Concrete l t) - deriving (Eq, Ord, Show) - -data Abstract cat name = Abs cat [cat] name - deriving (Eq, Ord, Show) -data Concrete lin term = Cnc lin [lin] term - deriving (Eq, Ord, Show) - ----------------------------------------------------------------------- - -instance (Print c, Print n, Print l, Print t) => Print (Rule n c l t) where - prt (Rule abs cnc) = prt abs ++ " := " ++ prt cnc ++ "\n" - prtList = concatMap prt - -instance (Print c, Print n) => Print (Abstract c n) where - prt (Abs cat args name) = prt name ++ ". " ++ prt cat ++ - ( if null args then "" - else " -> " ++ prtSep " " args ) - -instance (Print l, Print t) => Print (Concrete l t) where - prt (Cnc lcat args term) = prt term ++ " : " ++ prt lcat ++ - ( if null args then "" - else " [ " ++ prtSep " " args ++ " ]" ) diff --git a/src-3.0/GF/OldParsing/GeneralChart.hs b/src-3.0/GF/OldParsing/GeneralChart.hs deleted file mode 100644 index 1d51da025..000000000 --- a/src-3.0/GF/OldParsing/GeneralChart.hs +++ /dev/null @@ -1,86 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GeneralChart --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/11 13:52:53 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Simple implementation of deductive chart parsing ------------------------------------------------------------------------------ - - -module GF.OldParsing.GeneralChart - (-- * Type definition - Chart, - -- * Main functions - chartLookup, - buildChart, - -- * Probably not needed - emptyChart, - chartMember, - chartInsert, - chartList, - addToChart - ) where - --- import Trace - -import GF.Data.RedBlackSet - --- main functions - -chartLookup :: (Ord item, Ord key) => Chart item key -> key -> [item] -buildChart :: (Ord item, Ord key) => (item -> key) -> - [Chart item key -> item -> [item]] -> [item] -> [item] - -buildChart keyof rules axioms = chartList (addItems axioms emptyChart) - where addItems [] = id - addItems (item:items) = addItems items . addItem item - - -- addItem item | trace ("+ "++show item++"\n") False = undefined - addItem item = addToChart item (keyof item) - (\chart -> foldr (consequence item) chart rules) - - consequence item rule chart = addItems (rule chart item) chart - --- probably not needed - -emptyChart :: (Ord item, Ord key) => Chart item key -chartMember :: (Ord item, Ord key) => Chart item key -> item -> key -> Bool -chartInsert :: (Ord item, Ord key) => Chart item key -> item -> key -> Maybe (Chart item key) -chartList :: (Ord item, Ord key) => Chart item key -> [item] -addToChart :: (Ord item, Ord key) => item -> key -> (Chart item key -> Chart item key) -> Chart item key -> Chart item key - -addToChart item key after chart = maybe chart after (chartInsert chart item key) - - --------------------------------------------------------------------------------- --- key charts as red/black trees - -newtype Chart item key = KC (RedBlackMap key item) - deriving Show - -emptyChart = KC rbmEmpty -chartMember (KC tree) item key = rbmElem key item tree -chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree) -chartLookup (KC tree) key = rbmLookup key tree -chartList (KC tree) = concatMap snd (rbmList tree) ---------------------------------------------------------------------------------} - - -{-------------------------------------------------------------------------------- --- key charts as unsorted association lists -- OBSOLETE! - -newtype Chart item key = SC [(key, item)] - -emptyChart = SC [] -chartMember (SC chart) item key = (key,item) `elem` chart -chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart)) -chartLookup (SC chart) key = [ item | (key',item) <- chart, key == key' ] -chartList (SC chart) = map snd chart ---------------------------------------------------------------------------------} - diff --git a/src-3.0/GF/OldParsing/GrammarTypes.hs b/src-3.0/GF/OldParsing/GrammarTypes.hs deleted file mode 100644 index fc514fc75..000000000 --- a/src-3.0/GF/OldParsing/GrammarTypes.hs +++ /dev/null @@ -1,148 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:46 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- All possible instantiations of different grammar formats used for parsing --- --- Plus some helper types and utilities ------------------------------------------------------------------------------ - - -module GF.OldParsing.GrammarTypes - (-- * Main parser information - PInfo(..), - -- * Multiple context-free grammars - MCFGrammar, MCFRule, MCFPInfo, - MCFCat(..), MCFLabel, - Constraint, - -- * Context-free grammars - CFGrammar, CFRule, CFPInfo, - CFProfile, CFName(..), CFCat(..), - -- * Assorted types - Cat, Name, Constr, Label, Tokn, - -- * Simplified terms - STerm(..), (+.), (+!), - -- * Record\/table paths - Path(..), emptyPath, - (++.), (++!) - ) where - -import GF.Infra.Ident (Ident(..)) -import GF.Canon.AbsGFC --- import qualified GF.OldParsing.FiniteTypes.Calc as Fin -import qualified GF.OldParsing.CFGrammar as CFG -import qualified GF.OldParsing.MCFGrammar as MCFG -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - -import qualified GF.OldParsing.ConvertGFCtoSimple - ----------------------------------------------------------------------- - -data PInfo = PInfo { mcfg :: MCFGrammar, - cfg :: CFGrammar, - mcfPInfo :: MCFPInfo, - cfPInfo :: CFPInfo } - -type MCFGrammar = MCFG.Grammar Name MCFCat MCFLabel Tokn -type MCFRule = MCFG.Rule Name MCFCat MCFLabel Tokn -type MCFPInfo = MCFG.PInfo Name MCFCat MCFLabel Tokn - -data MCFCat = MCFCat Cat [Constraint] deriving (Eq, Ord, Show) -type MCFLabel = Path - -type Constraint = (Path, STerm) - -type CFGrammar = CFG.Grammar CFName CFCat Tokn -type CFRule = CFG.Rule CFName CFCat Tokn -type CFPInfo = CFG.PInfo CFName CFCat Tokn - -type CFProfile = [[Int]] -data CFName = CFName Name CFProfile deriving (Eq, Ord, Show) -data CFCat = CFCat MCFCat MCFLabel deriving (Eq, Ord, Show) - ----------------------------------------------------------------------- - -type Cat = Ident -type Name = Ident -type Constr = CIdent - -data STerm = SArg Int Cat Path -- ^ argument variable, the 'Path' is a path - -- pointing into the term - | SCon Constr [STerm] -- ^ constructor - | SRec [(Label, STerm)] -- ^ record - | STbl [(STerm, STerm)] -- ^ table of patterns\/terms - | SVariants [STerm] -- ^ variants - | SConcat STerm STerm -- ^ concatenation - | SToken Tokn -- ^ single token - | SEmpty -- ^ empty string - | SWildcard -- ^ wildcard pattern variable - - -- SRes CIdent -- resource identifier - -- SVar Ident -- bound pattern variable - -- SInt Integer -- integer - deriving (Eq, Ord, Show) - -(+.) :: STerm -> Label -> STerm -SRec record +. lbl = maybe err id $ lookup lbl record - where err = error $ "(+.), label not in record: " ++ show (SRec record) ++ " +. " ++ show lbl -SArg arg cat path +. lbl = SArg arg cat (path ++. lbl) -SVariants terms +. lbl = SVariants $ map (+. lbl) terms -sterm +. lbl = error $ "(+.): " ++ show sterm ++ " +. " ++ show lbl - -(+!) :: STerm -> STerm -> STerm -STbl table +! pat = maybe err id $ lookup pat table - where err = error $ "(+!), pattern not in table: " ++ show (STbl table) ++ " +! " ++ show pat -SArg arg cat path +! pat = SArg arg cat (path ++! pat) -SVariants terms +! pat = SVariants $ map (+! pat) terms -term +! SVariants pats = SVariants $ map (term +!) pats -sterm +! pat = error $ "(+!): " ++ show sterm ++ " +! " ++ show pat - ----------------------------------------------------------------------- - -newtype Path = Path [Either Label STerm] deriving (Eq, Ord, Show) - -emptyPath :: Path -emptyPath = Path [] - -(++.) :: Path -> Label -> Path -Path path ++. lbl = Path (Left lbl : path) - -(++!) :: Path -> STerm -> Path -Path path ++! sel = Path (Right sel : path) - ------------------------------------------------------------- - -instance Print STerm where - prt (SArg n c p) = prt c ++ "@" ++ prt n ++ prt p - prt (SCon c []) = prt c - prt (SCon c ts) = prt c ++ prtList ts - prt (SRec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ ";" | (l,t) <- rec ] ++ "}" - prt (STbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ ";" | (p,t) <- tbl ] ++ "}" - prt (SVariants ts) = "{| " ++ prtSep " | " ts ++ " |}" - prt (SConcat t1 t2) = prt t1 ++ "++" ++ prt t2 - prt (SToken t) = prt t - prt (SEmpty) = "[]" - prt (SWildcard) = "_" - -instance Print MCFCat where - prt (MCFCat cat params) - = prt cat ++ "{" ++ concat [ prt path ++ "=" ++ prt term ++ ";" | - (path, term) <- params ] ++ "}" - -instance Print CFName where - prt (CFName name profile) = prt name ++ prt profile - -instance Print CFCat where - prt (CFCat cat lbl) = prt cat ++ prt lbl - -instance Print Path where - prt (Path path) = concatMap prtEither (reverse path) - where prtEither (Left lbl) = "." ++ prt lbl - prtEither (Right patt) = "!" ++ prt patt diff --git a/src-3.0/GF/OldParsing/IncrementalChart.hs b/src-3.0/GF/OldParsing/IncrementalChart.hs deleted file mode 100644 index 132ed4dc4..000000000 --- a/src-3.0/GF/OldParsing/IncrementalChart.hs +++ /dev/null @@ -1,50 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : IncrementalChart --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:47 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Implementation of /incremental/ deductive parsing, --- i.e. parsing one word at the time. ------------------------------------------------------------------------------ - - -module GF.OldParsing.IncrementalChart - (-- * Type definitions - IncrementalChart, - -- * Functions - buildChart, - chartList - ) where - -import Data.Array -import GF.Data.SortedList -import GF.Data.Assoc - -buildChart :: (Ord item, Ord key) => (item -> key) -> - (Int -> item -> SList item) -> - (Int -> SList item) -> - (Int, Int) -> IncrementalChart item key - -chartList :: (Ord item, Ord key) => (Int -> item -> edge) -> IncrementalChart item key -> [edge] - -type IncrementalChart item key = Array Int (Assoc key (SList item)) - ----------- - -buildChart keyof rules axioms bounds = finalChartArray - where buildState k = limit (rules k) $ axioms k - finalChartList = map buildState [fst bounds .. snd bounds] - finalChartArray = listArray bounds $ map stateAssoc finalChartList - stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ] - -chartList combine chart = [ combine k item | - (k, state) <- assocs chart, - item <- concatMap snd $ aAssocs state ] - - diff --git a/src-3.0/GF/OldParsing/MCFGrammar.hs b/src-3.0/GF/OldParsing/MCFGrammar.hs deleted file mode 100644 index ff9d7de1b..000000000 --- a/src-3.0/GF/OldParsing/MCFGrammar.hs +++ /dev/null @@ -1,206 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MCFGrammar --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:48 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Definitions of multiple context-free grammars, --- parser information and chart conversion ------------------------------------------------------------------------------ - -module GF.OldParsing.MCFGrammar - (-- * Type definitions - Grammar, - Rule(..), - Lin(..), - -- * Parser information - MCFParser, - MEdge, - edges2chart, - PInfo, - pInfo, - -- * Ranges - Range(..), - makeRange, - concatRange, - unifyRange, - unionRange, - failRange, - -- * Utilities - select, - updateIndex - ) where - --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc --- parser modules: -import GF.OldParsing.Utilities -import GF.Printing.PrintParser - - - -select :: [a] -> [(a, [a])] -select [] = [] -select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ] - -updateIndex :: Functor f => Int -> [a] -> (a -> f a) -> f [a] -updateIndex 0 (a:as) f = fmap (:as) $ f a -updateIndex n (a:as) f = fmap (a:) $ updateIndex (n-1) as f -updateIndex _ _ _ = error "ParserUtils.updateIndex: Index out of range" - - ------------------------------------------------------------- --- grammar types - -type Grammar n c l t = [Rule n c l t] -data Rule n c l t = Rule c [c] [Lin c l t] n - deriving (Eq, Ord, Show) -data Lin c l t = Lin l [Symbol (c, l, Int) t] - deriving (Eq, Ord, Show) - --- variants is simply several linearizations with the same label - - ------------------------------------------------------------- --- parser information - -type PInfo n c l t = Grammar n c l t - -pInfo :: Grammar n c l t -> PInfo n c l t -pInfo = id - -type MCFParser n c l t = PInfo n c l t -> [c] -> Input t -> ParseChart n (MEdge c l) - -type MEdge c l = (c, [(l, Range)]) - -edges2chart :: (Ord n, Ord c, Ord l) => - [(n, MEdge c l, [MEdge c l])] -> ParseChart n (MEdge c l) -edges2chart edges = fmap groupPairs $ accumAssoc id $ - [ (medge, (name, medges)) | (name, medge, medges) <- edges ] - - ------------------------------------------------------------- --- ranges as sets of int-pairs - -newtype Range = Rng (SList (Int, Int)) deriving (Eq, Ord, Show) - -makeRange :: SList (Int, Int) -> Range -makeRange rho = Rng rho - -concatRange :: Range -> Range -> Range -concatRange (Rng rho) (Rng rho') = Rng $ nubsort [ (i,k) | (i,j) <- rho, (j',k) <- rho', j==j' ] - -unifyRange :: Range -> Range -> Range -unifyRange (Rng rho) (Rng rho') = Rng $ rho <**> rho' - -unionRange :: Range -> Range -> Range -unionRange (Rng rho) (Rng rho') = Rng $ rho <++> rho' - -failRange :: Range -failRange = Rng [] - - ------------------------------------------------------------- --- pretty-printing - -instance (Print n, Print c, Print l, Print t) => Print (Rule n c l t) where - prt (Rule cat args record name) - = prt name ++ ". " ++ prt cat ++ " -> " ++ prtSep " " args ++ "\n" ++ prt record - prtList = concatMap prt - -instance (Print c, Print l, Print t) => Print (Lin c l t) where - prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin) - where prArg (cat, lbl, arg) = prt cat ++ "@" ++ prt arg ++ "." ++ prt lbl - prtList = prtBeforeAfter "\t" "\n" - -instance Print Range where - prt (Rng rho) = "(" ++ prtSep "|" [ show i ++ "-" ++ show j | (i,j) <- rho ] ++ ")" - -{- ------------------------------------------------------------- --- items & forests - -data Item n c l = Item n (MEdge c l) [[MEdge c l]] - deriving (Eq, Ord, Show) -type MEdge c l = (c, [Edge l]) - -items2forests :: (Ord n, Ord c, Ord l) => Edge ((c, l) -> Bool) -> [Item n c l] -> [ParseForest n] - ----------- - -items2forests (Edge i0 k0 startCat) items - = concatMap edge2forests $ filter checkEdge $ aElems chart - where edge2forests (cat, []) = [FMeta] - edge2forests edge = filter checkForest $ map item2forest (chart ? edge) - - item2forest (Item name _ children) = FNode name [ forests | edges <- children, - forests <- mapM edge2forests edges ] - - checkEdge (cat, [Edge i k lbl]) = i == i0 && k == k0 && startCat (cat, lbl) - checkEdge _ = False - - checkForest (FNode _ children) = not (null children) - - chart = accumAssoc id [ (edge, item) | item@(Item _ edge _) <- items ] --} - - ------------------------------------------------------------- --- grammar checking -{- ---checkGrammar :: (Ord c, Ord l, Print n, Print c, Print l, Print t) => Grammar n c l t -> [String] - -checkGrammar rules - = do rule@(Rule cat rhs record name) <- rules - if null record - then [ "empty linearization record in rule: " ++ prt rule ] - else [ "category does not exist: " ++ prt rcat ++ "\n" ++ - " - in rule: " ++ prt rule | - rcat <- rhs, rcat `notElem` lhsCats ] ++ - do Lin _ lin <- record - Cat (arg, albl) <- lin - if arg<0 || arg>=length rhs - then [ "argument index out of range: " ++ show arg ++ "/" ++ prt albl ++ "\n" ++ - " - in rule: " ++ prt rule ] - else [ "label does not exist: " ++ prt albl ++ "\n" ++ - " - from rule: " ++ prt rule ++ - " - in rule: " ++ prt arule | - arule@(Rule _ acat _ arecord) <- rules, - acat == rhs !! arg, - albl `notElem` [ lbl | Lin lbl _ <- arecord ] ] - where lhsCats = nubsort [ cat | Rule _ cat _ _ <- rules ] --} - - - - - -{----- ------------------------------------------------------------- --- simplifications - -splitMRule :: (Ord n, Ord c, Ord l, Ord t) => Grammar n c l t -> Rule n c l t -> [Rule n c l t] -splitMRule rules (Rule name cat args record) = nubsort [ (Rule name cat args splitrec) | - (cat', lbls) <- rhsCats, cat == cat', - let splitrec = [ lin | lin@(Lin lbl _) <- record, lbl `elem` lbls ] ] - where rhsCats = limit rhsC lhsCats - lhsCats = nubsort [ (cat, [lbl]) | Rule _ cat _ record <- rules, Lin lbl _ <- record ] - rhsC (cat, lbls) = nubsort [ (rcat, rlbls) | - Rule _ cat' rhs lins <- rules, cat == cat', - (arg, rcat) <- zip [0..] rhs, - let rlbls = nubsort [ rlbl | Lin lbl lin <- lins, lbl `elem` lbls, - Cat (arg', rlbl) <- lin, arg == arg' ], - not $ null rlbls - ] - - -----} - - - diff --git a/src-3.0/GF/OldParsing/ParseCF.hs b/src-3.0/GF/OldParsing/ParseCF.hs deleted file mode 100644 index e1ef32aee..000000000 --- a/src-3.0/GF/OldParsing/ParseCF.hs +++ /dev/null @@ -1,82 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCF --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:49 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Chart parsing of grammars in CF format ------------------------------------------------------------------------------ - -module GF.OldParsing.ParseCF (parse, alternatives) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - -import GF.Data.SortedList (nubsort) -import GF.Data.Assoc -import qualified GF.CF.CF as CF -import qualified GF.CF.CFIdent as CFI -import GF.OldParsing.Utilities -import GF.OldParsing.CFGrammar -import qualified GF.OldParsing.ParseCFG as P - -type Token = CFI.CFTok -type Name = CFI.CFFun -type Category = CFI.CFCat - -alternatives :: [(String, [String])] -alternatives = [ ("gb", ["G","GB","_gen","_genBU"]), - ("gt", ["GT","_genTD"]), - ("ibn", ["","I","B","IB","IBN","_inc","BU","_incBU"]), - ("ibb", ["BB","IBB","BU_BUF","_incBU_BUF"]), - ("ibt", ["BT","IBT","BU_TDF","_incBU_TDF"]), - ("iba", ["BA","IBA","BU_BTF","BU_TBF","_incBU_BTF","_incBU_TBF"]), - ("itn", ["T","IT","ITN","TD","_incTD"]), - ("itb", ["TB","ITB","TD_BUF","_incTD_BUF"]) - ] - -parse :: String -> CF.CF -> Category -> CF.CFParser -parse = buildParser . P.parse - -buildParser :: CFParser Name Category Token -> CF.CF -> Category -> CF.CFParser -buildParser parser cf start tokens = trace "ParseCF" $ - (parseResults, parseInformation) - where parseInformation = prtSep "\n" trees - parseResults = {-take maxTake-} [ (tree2cfTree t, []) | t <- trees ] - theInput = input tokens - edges = tracePrt "#edges" (prt.length) $ - parser pInf [start] theInput - chart = tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ - edges2chart theInput $ map (fmap addCategory) edges - forests = tracePrt "#forests" (prt.length) $ - chart2forests chart (const False) $ - uncurry Edge (inputBounds theInput) start - trees = tracePrt "#trees" (prt.length) $ - concatMap forest2trees forests - pInf = pInfo $ cf2grammar cf (nubsort tokens) - - -addCategory (Rule cat rhs name) = Rule cat rhs (name, cat) - -tree2cfTree (TNode (name, cat) trees) = CF.CFTree (name, (cat, map tree2cfTree trees)) - -cf2grammar :: CF.CF -> [Token] -> Grammar Name Category Token -cf2grammar cf tokens = [ Rule cat rhs name | - (name, (cat, rhs0)) <- cfRules, - rhs <- mapM item2symbol rhs0 ] - where cfRules = concatMap (CF.predefRules (CF.predefOfCF cf)) tokens ++ - CF.rulesOfCF cf - item2symbol (CF.CFNonterm cat) = [Cat cat] - item2symbol item = map Tok $ filter (CF.matchCFTerm item) tokens - --- maxTake :: Int --- maxTake = 500 --- maxTake = maxBound - - diff --git a/src-3.0/GF/OldParsing/ParseCFG.hs b/src-3.0/GF/OldParsing/ParseCFG.hs deleted file mode 100644 index 03c1d7dcc..000000000 --- a/src-3.0/GF/OldParsing/ParseCFG.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:49 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Main parsing module for context-free grammars ------------------------------------------------------------------------------ - - -module GF.OldParsing.ParseCFG (parse) where - -import Data.Char (toLower) -import GF.OldParsing.Utilities -import GF.OldParsing.CFGrammar -import qualified GF.OldParsing.ParseCFG.General as PGen -import qualified GF.OldParsing.ParseCFG.Incremental as PInc - - -parse :: (Ord n, Ord c, Ord t, Show t) => - String -> CFParser n c t -parse = decodeParser . map toLower - -decodeParser ['g',s] = PGen.parse (decodeStrategy s) -decodeParser ['i',s,f] = PInc.parse (decodeStrategy s, decodeFilter f) -decodeParser _ = decodeParser "ibn" - -decodeStrategy 'b' = (True, False) -decodeStrategy 't' = (False, True) - -decodeFilter 'a' = (True, True) -decodeFilter 'b' = (True, False) -decodeFilter 't' = (False, True) -decodeFilter 'n' = (False, False) - - - - diff --git a/src-3.0/GF/OldParsing/ParseCFG/General.hs b/src-3.0/GF/OldParsing/ParseCFG/General.hs deleted file mode 100644 index 438c89f1a..000000000 --- a/src-3.0/GF/OldParsing/ParseCFG/General.hs +++ /dev/null @@ -1,83 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCFG.General --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Several implementations of CFG chart parsing ------------------------------------------------------------------------------ - -module GF.OldParsing.ParseCFG.General - (parse, Strategy) where - -import GF.System.Tracing - -import GF.OldParsing.Utilities -import GF.OldParsing.CFGrammar -import GF.OldParsing.GeneralChart -import GF.Data.Assoc - -parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser n c t -parse strategy grammar start = extract . process strategy grammar start - -type Strategy = (Bool, Bool) -- (isBottomup, isTopdown) - -extract :: [Item n (Symbol c t)] -> [Edge (Rule n c t)] -extract edges = - edges' - where edges' = [ Edge j k (Rule cat (reverse found) name) | - Edge j k (Cat cat, found, [], Just name) <- edges ] - -process :: (Ord n, Ord c, Ord t) => Strategy -> PInfo n c t -> - [c] -> Input t -> [Item n (Symbol c t)] -process (isBottomup, isTopdown) grammar start - = trace2 "CFParserGeneral" ((if isBottomup then " BU" else "") ++ - (if isTopdown then " TD" else "")) $ - buildChart keyof [predict, combine] . axioms - where axioms input = initial ++ scan input - - scan input = map (fmap mkEdge) (inputEdges input) - mkEdge tok = (Tok tok, [], [], Nothing) - - -- the combine rule - combine chart (Edge j k (next, _, [], _)) - = [ edge `forwardTo` k | edge <- chartLookup chart (Active next j) ] - combine chart edge@(Edge _ j (_, _, next:_, _)) - = [ edge `forwardTo` k | Edge _ k _ <- chartLookup chart (Passive next j) ] - - -- initial predictions - initial = [ loopingEdge 0 rule | cat <- start, rule <- tdRuleLookup ? cat ] - - -- predictions - predict chart (Edge j k (next, _, [], _)) | isBottomup - = [ loopingEdge j rule `forwardTo` k | rule <- bottomupRules grammar ? next ] - -- - - - - - - - - - ^^^^^^^^^^^^^ Kilbury prediction: move dot forward - predict chart (Edge _ k (_, _, Cat cat:_, _)) - = [ loopingEdge k rule | rule <- tdRuleLookup ? cat ] - predict _ _ = [] - - tdRuleLookup | isTopdown = topdownRules grammar - | isBottomup = emptyLeftcornerRules grammar - --- internal representation of parse items - -type Item n s = Edge (s, [s], [s], Maybe n) -type IChart n s = Chart (Item n s) (IKey s) -data IKey s = Active s Int - | Passive s Int - deriving (Eq, Ord, Show) - -keyof (Edge _ j (_, _, next:_, _)) = Active next j -keyof (Edge j _ (cat, _, [], _)) = Passive cat j - -forwardTo (Edge i j (cat, found, next:tofind, name)) k = Edge i k (cat, next:found, tofind, name) - -loopingEdge k (Rule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name) - - - diff --git a/src-3.0/GF/OldParsing/ParseCFG/Incremental.hs b/src-3.0/GF/OldParsing/ParseCFG/Incremental.hs deleted file mode 100644 index f1bcde404..000000000 --- a/src-3.0/GF/OldParsing/ParseCFG/Incremental.hs +++ /dev/null @@ -1,142 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseCFG.Incremental --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Incremental chart parsing for context-free grammars ------------------------------------------------------------------------------ - - - -module GF.OldParsing.ParseCFG.Incremental - (parse, Strategy) where - -import GF.System.Tracing -import GF.Printing.PrintParser - --- haskell modules: -import Data.Array --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Data.Operations --- parser modules: -import GF.OldParsing.Utilities -import GF.OldParsing.CFGrammar -import GF.OldParsing.IncrementalChart - - -type Strategy = ((Bool, Bool), (Bool, Bool)) -- (predict:(BU, TD), filter:(BU, TD)) - -parse :: (Ord n, Ord c, Ord t, Show t) => - Strategy -> CFParser n c t -parse ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input = - trace2 "CFParserIncremental" - ((if isPredictBU then "BU-predict " else "") ++ - (if isPredictTD then "TD-predict " else "") ++ - (if isFilterBU then "BU-filter " else "") ++ - (if isFilterTD then "TD-filter " else "")) $ - finalEdges - where finalEdges = [ Edge j k (Rule cat (reverse found) name) | - (k, state) <- - tracePrt "#passiveChart" - (prt . map (length . (?Passive) . snd)) $ - tracePrt "#activeChart" - (prt . map (length . concatMap snd . aAssocs . snd)) $ - assocs finalChart, - Item j (Rule cat _Nil name) found <- state ? Passive ] - - finalChart = buildChart keyof rules axioms $ inputBounds input - - axioms 0 = --tracePrt ("axioms 0") (prtSep "\n") $ - union $ map (tdInfer 0) start - axioms k = --tracePrt ("axioms "++show k) (prtSep "\n") $ - union [ buInfer j k (Tok token) | - (token, js) <- aAssocs (inputTo input ! k), j <- js ] - - rules k (Item j (Rule cat [] _) _) - = buInfer j k (Cat cat) - rules k (Item j rule@(Rule _ (Cat next:_) _) found) - = tdInfer k next <++> - -- hack for empty rules: - [ Item j (forward rule) (Cat next:found) | - emptyCategories grammar ?= next ] - rules _ _ = [] - - buInfer j k next = --tracePrt ("buInfer "++show(j,k)++" "++prt next) (prtSep "\n") $ - buPredict j k next <++> buCombine j k next - tdInfer k next = tdPredict k next - - -- the combine rule - buCombine j k next - | j == k = [] -- hack for empty rules - | otherwise = [ Item i (forward rule) (next:found) | - Item i rule found <- (finalChart ! j) ? Active next ] - - -- kilbury bottom-up prediction - buPredict j k next - = [ Item j rule [next] | isPredictBU, - rule <- map forward $ --tracePrt ("buRules "++prt next) (prtSep "\n") $ - bottomupRules grammar ? next, - buFilter rule k, - tdFilter rule j k ] - - -- top-down prediction - tdPredict k cat - = [ Item k rule [] | isPredictTD || isFilterTD, - rule <- topdownRules grammar ? cat, - buFilter rule k ] <++> - -- hack for empty rules: - [ Item k rule [] | isPredictBU, - rule <- emptyLeftcornerRules grammar ? cat ] - - -- bottom up filtering: input symbol k can begin the given symbol list (first set) - -- leftcornerTokens DOESN'T WORK WITH EMPTY RULES!!! - buFilter (Rule _ (Cat cat:_) _) k | isFilterBU - = k < snd (inputBounds input) && - hasCommonElements (leftcornerTokens grammar ? cat) - (aElems (inputFrom input ! k)) - buFilter _ _ = True - - -- top down filtering: 'cat' is reachable by an active edge ending in node j < k - tdFilter (Rule cat _ _) j k | isFilterTD && j < k - = (tdFilters ! j) ?= cat - tdFilter _ _ _ = True - - tdFilters = listArray (inputBounds input) $ - map (listSet . limit leftCats . activeCats) [0..] - activeCats j = [ next | Active (Cat next) <- aElems (finalChart ! j) ] - leftCats cat = [ left | Rule _cat (Cat left:_) _ <- topdownRules grammar ? cat ] - - --- type declarations, items & keys -data Item n c t = Item Int (Rule n c t) [Symbol c t] - deriving (Eq, Ord, Show) - -data IKey c t = Active (Symbol c t) | Passive - deriving (Eq, Ord, Show) - -keyof :: Item n c t -> IKey c t -keyof (Item _ (Rule _ (next:_) _) _) = Active next -keyof (Item _ (Rule _ [] _) _) = Passive - -forward :: Rule n c t -> Rule n c t -forward (Rule cat (_:rest) name) = Rule cat rest name - - -instance (Print n, Print c, Print t) => Print (Item n c t) where - prt (Item k (Rule cat rhs name) syms) - = "<" ++show k++ ": "++prt name++". "++ - prt cat++" -> "++prt rhs++" / "++prt syms++">" - -instance (Print c, Print t) => Print (IKey c t) where - prt (Active sym) = "?" ++ prt sym - prt (Passive) = "!" - - diff --git a/src-3.0/GF/OldParsing/ParseGFC.hs b/src-3.0/GF/OldParsing/ParseGFC.hs deleted file mode 100644 index fbc6cff5a..000000000 --- a/src-3.0/GF/OldParsing/ParseGFC.hs +++ /dev/null @@ -1,177 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseGFC --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:50 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- The main parsing module, parsing GFC grammars --- by translating to simpler formats, such as PMCFG and CFG ----------------------------------------------------------------------- - -module GF.OldParsing.ParseGFC (newParser) where - -import GF.System.Tracing -import GF.Printing.PrintParser -import qualified GF.Grammar.PrGrammar as PrGrammar - --- Haskell modules -import Control.Monad --- import Ratio ((%)) --- GF modules -import qualified GF.Grammar.Grammar as GF -import GF.Grammar.Values -import qualified GF.Grammar.Macros as Macros -import qualified GF.Infra.Modules as Mods -import qualified GF.Canon.AbsGFC as AbsGFC -import qualified GF.Infra.Ident as Ident -import qualified GF.Compile.ShellState as SS -import GF.Data.Operations -import GF.Data.SortedList --- Conversion and parser modules -import GF.Data.Assoc -import GF.OldParsing.Utilities --- import ConvertGrammar -import GF.OldParsing.GrammarTypes -import qualified GF.OldParsing.MCFGrammar as M -import qualified GF.OldParsing.CFGrammar as C -import qualified GF.OldParsing.ParseMCFG as PM -import qualified GF.OldParsing.ParseCFG as PC ---import MCFRange - -newParser :: String -> SS.StateGrammar -> GF.Cat -> String -> Err [GF.Term] - --- parsing via MCFG -newParser (m:strategy) gr (_, startCat) inString - | m=='m' || m=='M' = trace2 "Parser" "MCFG" $ Ok terms - where terms = map (ptree2term abstract) trees - trees = --tracePrt "trees" (prtBefore "\n") $ - tracePrt "#trees" (prt . length) $ - concatMap forest2trees forests - forests = --tracePrt "forests" (prtBefore "\n") $ - tracePrt "#forests" (prt . length) $ - concatMap (chart2forests chart isMeta) finalEdges - isMeta = null . snd - finalEdges = tracePrt "finalEdges" (prtBefore "\n") $ - filter isFinalEdge $ aElems chart --- nubsort [ (cat, [(lbl, E.makeRange [(i,j)])]) | --- let (i, j) = inputBounds inTokens, --- E.Rule cat _ [E.Lin lbl _] _ <- pInf, --- isStartCat cat ] - isFinalEdge (cat, rows) - = isStartCat cat && - inputBounds inTokens `elem` concat [ rho | (_, M.Rng rho) <- rows ] - chart = --tracePrt "chart" (prtBefore "\n" . aAssocs) $ - tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ - PM.parse strategy pInf starters inTokens - inTokens = input $ map AbsGFC.KS $ words inString - pInf = -- tracePrt "avg rec" (\gr -> show (sum [ length rec | E.Rule _ _ rec _ <- gr ] % length gr)) $ - mcfPInfo $ SS.statePInfoOld gr - starters = tracePrt "startCats" prt $ - filter isStartCat $ nubsort [ cat | M.Rule cat _ _ _ <- pInf ] - isStartCat (MCFCat cat _) = cat == startCat - abstract = tracePrt "abstract module" PrGrammar.prt $ - SS.absId gr - --- parsing via CFG -newParser (c:strategy) gr (_, startCat) inString - | c=='c' || c=='C' = trace2 "Parser" "CFG" $ Ok terms - where terms = -- tracePrt "terms" (unlines . map PrGrammar.prt) $ - map (ptree2term abstract) trees - trees = tracePrt "#trees" (prt . length) $ - --tracePrt "trees" (prtSep "\n") $ - concatMap forest2trees forests - forests = tracePrt "$cfForests" (prt) $ -- . length) $ - tracePrt "forests" (unlines . map prt) $ - concatMap convertFromCFForest cfForests - cfForests= tracePrt "cfForests" (unlines . map prt) $ - concatMap (chart2forests chart (const False)) finalEdges - finalEdges = tracePrt "finalChartEdges" prt $ - map (uncurry Edge (inputBounds inTokens)) starters - chart = --tracePrt "finalChartEdges" (prt . (? finalEdge)) $ - tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ - C.edges2chart inTokens edges - edges = --tracePrt "finalEdges" - --(prt . filter (\(Edge i j _) -> (i,j)==inputBounds inTokens)) $ - tracePrt "#edges" (prt . length) $ - PC.parse strategy pInf starters inTokens - inTokens = input $ map AbsGFC.KS $ words inString - pInf = cfPInfo $ SS.statePInfoOld gr - starters = tracePrt "startCats" prt $ - filter isStartCat $ map fst $ aAssocs $ C.topdownRules pInf - isStartCat (CFCat (MCFCat cat _) _) = cat == startCat - abstract = tracePrt "abstract module" PrGrammar.prt $ - SS.absId gr - --ifNull (Ident.identC "ABS") last $ - --[i | (i, Mods.ModMod m) <- Mods.modules (SS.grammar gr), Mods.isModAbs m] - -newParser "" gr start inString = newParser "c" gr start inString - -newParser opt gr (_,cat) _ = - Bad ("new-parser '" ++ opt ++ "' not defined yet") - -ptree2term :: Ident.Ident -> ParseTree Name -> GF.Term -ptree2term a (TNode f ts) = Macros.mkApp (Macros.qq (a,f)) (map (ptree2term a) ts) -ptree2term a (TMeta) = GF.Meta (GF.MetaSymb 0) - ----------------------------------------------------------------------- --- conversion and unification of forests - -convertFromCFForest :: ParseForest CFName -> [ParseForest Name] -convertFromCFForest (FNode (CFName name profile) children) - | isCoercion name = concat chForests - | otherwise = [ FNode name chForests | not (null chForests) ] - where chForests = concat [ mapM (checkProfile forests) profile | - forests0 <- children, - forests <- mapM convertFromCFForest forests0 ] - checkProfile forests = unifyManyForests . map (forests !!) - -- foldM unifyForests FMeta . map (forests !!) - -isCoercion Ident.IW = True -isCoercion _ = False - -unifyManyForests :: Eq n => [ParseForest n] -> [ParseForest n] -unifyManyForests [] = [FMeta] -unifyManyForests [f] = [f] -unifyManyForests (f:g:fs) = do h <- unifyForests f g - unifyManyForests (h:fs) - -unifyForests :: Eq n => ParseForest n -> ParseForest n -> [ParseForest n] -unifyForests FMeta forest = [forest] -unifyForests forest FMeta = [forest] -unifyForests (FNode name1 children1) (FNode name2 children2) - = [ FNode name1 children | name1 == name2, not (null children) ] - where children = [ forests | forests1 <- children1, forests2 <- children2, - forests <- zipWithM unifyForests forests1 forests2 ] - - - -{- ----------------------------------------------------------------------- --- conversion and unification for parse trees instead of forests - -convertFromCFTree :: ParseTree CFName -> [ParseTree Name] -convertFromCFTree (TNode (CFName name profile) children0) - = [ TNode name children | - children1 <- mapM convertFromCFTree children0, - children <- mapM (checkProfile children1) profile ] - where checkProfile trees = unifyManyTrees . map (trees !!) - -unifyManyTrees :: Eq n => [ParseTree n] -> [ParseTree n] -unifyManyTrees [] = [TMeta] -unifyManyTrees [f] = [f] -unifyManyTrees (f:g:fs) = do h <- unifyTrees f g - unifyManyTrees (h:fs) - -unifyTrees TMeta tree = [tree] -unifyTrees tree TMeta = [tree] -unifyTrees (TNode name1 children1) (TNode name2 children2) - = [ TNode name1 children | name1 == name2, - children <- zipWithM unifyTrees children1 children2 ] - --} - diff --git a/src-3.0/GF/OldParsing/ParseMCFG.hs b/src-3.0/GF/OldParsing/ParseMCFG.hs deleted file mode 100644 index c845a76b3..000000000 --- a/src-3.0/GF/OldParsing/ParseMCFG.hs +++ /dev/null @@ -1,37 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseMCFG --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:52 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Main module for MCFG parsing ------------------------------------------------------------------------------ - - -module GF.OldParsing.ParseMCFG (parse) where - -import Data.Char (toLower) -import GF.OldParsing.Utilities -import GF.OldParsing.MCFGrammar -import qualified GF.OldParsing.ParseMCFG.Basic as PBas -import GF.Printing.PrintParser ----- import qualified MCFParserBasic2 as PBas2 -- file not found AR - - -parse :: (Ord n, Ord c, Ord l, Ord t, - Print n, Print c, Print l, Print t) => - String -> MCFParser n c l t -parse str = decodeParser (map toLower str) - -decodeParser "b" = PBas.parse ----- decodeParser "c" = PBas2.parse -decodeParser _ = decodeParser "b" - - - - diff --git a/src-3.0/GF/OldParsing/ParseMCFG/Basic.hs b/src-3.0/GF/OldParsing/ParseMCFG/Basic.hs deleted file mode 100644 index baf7e4b2a..000000000 --- a/src-3.0/GF/OldParsing/ParseMCFG/Basic.hs +++ /dev/null @@ -1,156 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ParseMCFG.Basic --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:03 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Simplest possible implementation of MCFG chart parsing ------------------------------------------------------------------------------ - -module GF.OldParsing.ParseMCFG.Basic - (parse) where - -import GF.System.Tracing - -import Data.Ix -import GF.OldParsing.Utilities -import GF.OldParsing.MCFGrammar -import GF.OldParsing.GeneralChart -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Printing.PrintParser - - -parse :: (Ord n, Ord c, Ord l, Ord t, - Print n, Print c, Print l, Print t) => - MCFParser n c l t -parse grammar start = edges2chart . extract . process grammar - - -extract :: [Item n c l t] -> [(n, MEdge c l, [MEdge c l])] -extract items = tracePrt "#passives" (prt.length) $ - --trace2 "passives" (prtAfter "\n" [ i | i@(PItem _) <- items ]) $ - [ item | PItem item <- items ] - - -process :: (Ord n, Ord c, Ord l, Ord t, - Print n, Print c, Print l, Print t) => - Grammar n c l t -> Input t -> [Item n c l t] -process grammar input = buildChart keyof rules axioms - where axioms = initial - rules = [combine, scan, predict] - - -- axioms - initial = traceItems "axiom" [] $ - [ nextLin name tofind (addNull cat) (map addNull args) | - Rule cat args tofind name <- grammar ] - - addNull a = (a, []) - - -- predict - predict chart i1@(Item name tofind rho (Lin lbl []) (cat, found0) children) - = traceItems "predict" [i1] - [ nextLin name tofind (cat, found) children | - let found = insertRow lbl rho found0 ] - predict _ _ = [] - - -- combine - combine chart active@(Item _ _ _ (Lin _ (Cat(cat,_,_):_)) _ _) - = do passive <- chartLookup chart (Passive cat) - combineItems active passive - combine chart passive@(PItem (_, (cat, _), _)) - = do active <- chartLookup chart (Active cat) - combineItems active passive - combine _ _ = [] - - combineItems i1@(Item name tofind rho0 (Lin lbl (Cat(_,lbl',nr):rest)) found children0) - i2@(PItem (_, found', _)) - = traceItems "combine" [i1,i2] - [ Item name tofind rho (Lin lbl rest) found children | - rho1 <- lookupLbl lbl' found', - let rho = concatRange rho0 rho1, - children <- updateChild nr children0 (snd found') ] - - -- scan - scan chart i1@(Item name tofind rho0 (Lin lbl (Tok tok:rest)) found children) - = traceItems "scan" [i1] - [ Item name tofind rho (Lin lbl rest) found children | - let rho = concatRange rho0 (rangeOfToken tok) ] - scan _ _ = [] - - -- utilities - rangeOfToken tok = makeRange $ inputToken input ? tok - - zeroRange = makeRange $ map (\i -> (i,i)) $ range $ inputBounds input - - nextLin name [] found children = PItem (name, found, children) - nextLin name (lin : tofind) found children - = Item name tofind zeroRange lin found children - -lookupLbl a = map snd . filter (\b -> a == fst b) . snd -updateChild nr children found = updateIndex nr children $ - \child -> if null (snd child) - then [ (fst child, found) ] - else [ child | snd child == found ] - -insertRow lbl rho [] = [(lbl, rho)] -insertRow lbl rho rows'@(row@(lbl', rho') : rows) - = case compare lbl lbl' of - LT -> row : insertRow lbl rho rows - GT -> (lbl, rho) : rows' - EQ -> (lbl, unionRange rho rho') : rows - - --- internal representation of parse items - -data Item n c l t - = Item n [Lin c l t] -- tofind - Range (Lin c l t) -- current row - (MEdge c l) -- found rows - [MEdge c l] -- found children - | PItem (n, MEdge c l, [MEdge c l]) - deriving (Eq, Ord, Show) - -data IKey c = Passive c | Active c | AnyItem - deriving (Eq, Ord, Show) - -keyof (PItem (_, (cat, _), _)) = Passive cat -keyof (Item _ _ _ (Lin _ (Cat(cat,_,_):_)) _ _) = Active cat -keyof _ = AnyItem - - --- tracing - ---type TraceItem = Item String String Char String -traceItems :: (Print n, Print l, Print c, Print t) => - String -> [Item n c l t] -> [Item n c l t] -> [Item n c l t] -traceItems rule trigs items - | null items || True = items - | otherwise = trace ("\n" ++ rule ++ ":" ++ - unlines [ "\t" ++ prt i | i <- trigs ] ++ "=>" ++ - unlines [ "\t" ++ prt i | i <- items ]) items - --- pretty-printing - -instance (Print n, Print c, Print l, Print t) => Print (Item n c l t) where - prt (Item name tofind rho lin (cat, found) children) - = prt name ++ ". " ++ prt cat ++ prtRhs (map fst children) ++ - " { " ++ prt rho ++ prt lin ++ " ; " ++ - concat [ prt lbl ++ "=" ++ prt ln ++ " " | - Lin lbl ln <- tofind ] ++ "; " ++ - concat [ prt lbl ++ "=" ++ prt rho ++ " " | - (lbl, rho) <- found ] ++ "} " ++ - concat [ "[ " ++ concat [ prt lbl ++ "=" ++ prt rho ++ " " | - (lbl,rho) <- child ] ++ "] " | - child <- map snd children ] - prt (PItem (name, edge, edges)) - = prt name ++ ". " ++ prt edge ++ prtRhs edges - -prtRhs [] = "" -prtRhs rhs = " -> " ++ prtSep " " rhs - diff --git a/src-3.0/GF/OldParsing/SimpleGFC.hs b/src-3.0/GF/OldParsing/SimpleGFC.hs deleted file mode 100644 index 59f379bb4..000000000 --- a/src-3.0/GF/OldParsing/SimpleGFC.hs +++ /dev/null @@ -1,161 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:52 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Simplistic GFC format ------------------------------------------------------------------------------ - -module GF.OldParsing.SimpleGFC where - -import qualified GF.Canon.AbsGFC as AbsGFC -import qualified GF.Infra.Ident as Ident - -import GF.Printing.PrintParser -import GF.Printing.PrintSimplifiedTerm - -import GF.Data.Operations (ifNull) - ----------------------------------------------------------------------- - -type Name = Ident.Ident -type Cat = Ident.Ident -type Constr = AbsGFC.CIdent -type Var = Ident.Ident -type Token = AbsGFC.Tokn -type Label = AbsGFC.Label - -constr2name :: Constr -> Name -constr2name (AbsGFC.CIQ _ name) = name - ----------------------------------------------------------------------- - -type Grammar = [Rule] -data Rule = Rule Name Typing (Maybe (Term, CType)) - deriving (Eq, Ord, Show) - -type Typing = (Type, [Decl]) - -data Decl = Var ::: Type - deriving (Eq, Ord, Show) -data Type = Cat :@ [Atom] - deriving (Eq, Ord, Show) -data Atom = ACon Constr - | AVar Var - deriving (Eq, Ord, Show) - -data CType = RecT [(Label, CType)] - | TblT CType CType - | ConT Constr [Term] - | StrT - deriving (Eq, Ord, Show) - - -data Term = Arg Int Cat Path -- ^ argument variable, the 'Path' is a path - -- pointing into the term - | Constr :^ [Term] -- ^ constructor - | Rec [(Label, Term)] -- ^ record - | Term :. Label -- ^ record projection - | Tbl [(Term, Term)] -- ^ table of patterns\/terms - | Term :! Term -- ^ table selection - | Variants [Term] -- ^ variants - | Term :++ Term -- ^ concatenation - | Token Token -- ^ single token - | Empty -- ^ empty string - | Wildcard -- ^ wildcard pattern variable - | Var Var -- ^ bound pattern variable - - -- Res CIdent -- resource identifier - -- Int Integer -- integer - deriving (Eq, Ord, Show) - - ----------------------------------------------------------------------- - -(+.) :: Term -> Label -> Term -Variants terms +. lbl = Variants $ map (+. lbl) terms -Rec record +. lbl = maybe err id $ lookup lbl record - where err = error $ "(+.), label not in record: " ++ show (Rec record) ++ " +. " ++ show lbl -Arg arg cat path +. lbl = Arg arg cat (path ++. lbl) -term +. lbl = term :. lbl - -(+!) :: Term -> Term -> Term -Variants terms +! pat = Variants $ map (+! pat) terms -term +! Variants pats = Variants $ map (term +!) pats -Tbl table +! pat = maybe err id $ lookup pat table - where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat -Arg arg cat path +! pat = Arg arg cat (path ++! pat) -term +! pat = term :! pat - -(?++) :: Term -> Term -> Term -Variants terms ?++ term = Variants $ map (?++ term) terms -term ?++ Variants terms = Variants $ map (term ?++) terms -Empty ?++ term = term -term ?++ Empty = term -term1 ?++ term2 = term1 :++ term2 - ----------------------------------------------------------------------- - -newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show) - -emptyPath :: Path -emptyPath = Path [] - -(++.) :: Path -> Label -> Path -Path path ++. lbl = Path (Left lbl : path) - -(++!) :: Path -> Term -> Path -Path path ++! sel = Path (Right sel : path) - ----------------------------------------------------------------------- - -instance Print Rule where - prt (Rule name (typ, args) term) - = prt name ++ " : " ++ - prtAfter " " args ++ - (if null args then "" else "-> ") ++ - prt typ ++ - maybe "" (\(t,c) -> " := " ++ prt t ++ " : " ++ prt c) term ++ - "\n" - prtList = concatMap prt - -instance Print Decl where - prt (var ::: typ) = "(" ++ prt var ++ ":" ++ prt typ ++ ")" - -instance Print Type where - prt (cat :@ ats) = prt cat ++ prtList ats - -instance Print Atom where - prt (ACon con) = prt con - prt (AVar var) = "?" ++ prt var - -instance Print CType where - prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}" - prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")" - prt (ConT t ts) = prt t ++ "(|" ++ prtSep "|" ts ++ "|)" - prt (StrT) = "Str" - -instance Print Term where - prt (Arg n c p) = prt c ++ "@" ++ prt n ++ prt p - prt (c :^ []) = prt c - prt (c :^ ts) = prt c ++ prtList ts - prt (Rec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}" - prt (Tbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "}" - prt (Variants ts) = "{| " ++ prtSep " | " ts ++ " |}" - prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2 - prt (Token t) = prt t - prt (Empty) = "[]" - prt (Wildcard) = "_" - prt (term :. lbl) = prt term ++ "." ++ prt lbl - prt (term :! sel) = prt term ++ " ! " ++ prt sel - prt (Var var) = "?" ++ prt var - -instance Print Path where - prt (Path path) = concatMap prtEither (reverse path) - where prtEither (Left lbl) = "." ++ prt lbl - prtEither (Right patt) = "!" ++ prt patt diff --git a/src-3.0/GF/OldParsing/Utilities.hs b/src-3.0/GF/OldParsing/Utilities.hs deleted file mode 100644 index 6bacfe1fe..000000000 --- a/src-3.0/GF/OldParsing/Utilities.hs +++ /dev/null @@ -1,188 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Parsing.Utilities --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:54 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Basic type declarations and functions to be used when parsing ------------------------------------------------------------------------------ - - -module GF.OldParsing.Utilities - ( -- * Symbols - Symbol(..), symbol, mapSymbol, - -- * Edges - Edge(..), - -- * Parser input - Input(..), makeInput, input, inputMany, - -- * charts, parse forests & trees - ParseChart, ParseForest(..), ParseTree(..), - chart2forests, forest2trees - ) where - --- haskell modules: -import Control.Monad -import Data.Array --- gf modules: -import GF.Data.SortedList -import GF.Data.Assoc --- parsing modules: -import GF.Printing.PrintParser - ------------------------------------------------------------- --- symbols - -data Symbol c t = Cat c | Tok t - deriving (Eq, Ord, Show) - -symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a -mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u - ----------- - -symbol fc ft (Cat cat) = fc cat -symbol fc ft (Tok tok) = ft tok - -mapSymbol fc ft = symbol (Cat . fc) (Tok . ft) - - ------------------------------------------------------------- --- edges - -data Edge s = Edge Int Int s - deriving (Eq, Ord, Show) - -instance Functor Edge where - fmap f (Edge i j s) = Edge i j (f s) - - ------------------------------------------------------------- --- parser input - -data Input t = MkInput { inputEdges :: [Edge t], - inputBounds :: (Int, Int), - inputFrom :: Array Int (Assoc t [Int]), - inputTo :: Array Int (Assoc t [Int]), - inputToken :: Assoc t [(Int, Int)] - } - -makeInput :: Ord t => [Edge t] -> Input t -input :: Ord t => [t] -> Input t -inputMany :: Ord t => [[t]] -> Input t - ----------- - -makeInput inEdges | null inEdges = input [] - | otherwise = MkInput inEdges inBounds inFrom inTo inToken - where inBounds = foldr1 minmax [ (i, j) | Edge i j _ <- inEdges ] - where minmax (a, b) (a', b') = (min a a', max b b') - inFrom = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds $ - [ (i, [(tok, j)]) | Edge i j tok <- inEdges ] - inTo = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds - [ (j, [(tok, i)]) | Edge i j tok <- inEdges ] - inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] - -input toks = MkInput inEdges inBounds inFrom inTo inToken - where inEdges = zipWith3 Edge [0..] [1..] toks - inBounds = (0, length toks) - inFrom = listArray inBounds $ - [ listAssoc [(tok, [j])] | (tok, j) <- zip toks [1..] ] ++ [ listAssoc [] ] - inTo = listArray inBounds $ - [ listAssoc [] ] ++ [ listAssoc [(tok, [i])] | (tok, i) <- zip toks [0..] ] - inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] - -inputMany toks = MkInput inEdges inBounds inFrom inTo inToken - where inEdges = [ Edge i j t | (i, j, ts) <- zip3 [0..] [1..] toks, t <- ts ] - inBounds = (0, length toks) - inFrom = listArray inBounds $ - [ listAssoc [ (t, [j]) | t <- nubsort ts ] | (ts, j) <- zip toks [1..] ] - ++ [ listAssoc [] ] - inTo = listArray inBounds $ - [ listAssoc [] ] ++ - [ listAssoc [ (t, [i]) | t <- nubsort ts ] | (ts, i) <- zip toks [0..] ] - inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] - - ------------------------------------------------------------- --- charts, parse forests & trees - -type ParseChart n e = Assoc e [(n, [[e]])] - -data ParseForest n = FNode n [[ParseForest n]] | FMeta - deriving (Eq, Ord, Show) - -data ParseTree n = TNode n [ParseTree n] | TMeta - deriving (Eq, Ord, Show) - -chart2forests :: Ord e => ParseChart n e -> (e -> Bool) -> e -> [ParseForest n] - ---filterCoercions :: (n -> Bool) -> ParseForest n -> [ParseForest n] - -forest2trees :: ParseForest n -> [ParseTree n] - -instance Functor ParseTree where - fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees - fmap f (TMeta) = TMeta - -instance Functor ParseForest where - fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests - fmap f (FMeta) = FMeta - ----------- - -chart2forests chart isMeta = edge2forests - where item2forest (name, children) = FNode name $ - do edges <- children - mapM edge2forests edges - edge2forests edge - | isMeta edge = [FMeta] - | otherwise = filter checkForest $ map item2forest $ chart ? edge - checkForest (FNode _ children) = not (null children) - --- filterCoercions _ (FMeta) = [FMeta] --- filterCoercions isCoercion (FNode s forests) --- | isCoercion s = do [forest] <- forests ; filterCoercions isCoercion forest --- | otherwise = FNode s $ do children <- forests ; mapM (filterCoercions isCoercion) - -forest2trees (FNode s forests) = map (TNode s) $ forests >>= mapM forest2trees -forest2trees (FMeta) = [TMeta] - - - ------------------------------------------------------------- --- pretty-printing - -instance (Print c, Print t) => Print (Symbol c t) where - prt = symbol prt (simpleShow.prt) - prtList = prtSep " " - -simpleShow :: String -> String -simpleShow s = "\"" ++ concatMap mkEsc s ++ "\"" - where - mkEsc :: Char -> String - mkEsc c = case c of - _ | elem c "\\\"" -> '\\' : [c] - '\n' -> "\\n" - '\t' -> "\\t" - _ -> [c] - -instance (Print s) => Print (Edge s) where - prt (Edge i j s) = "[" ++ show i ++ "-" ++ show j ++ ": " ++ prt s ++ "]" - prtList = prtSep "" - -instance (Print s) => Print (ParseTree s) where - prt (TNode s trees) = prt s ++ "^{" ++ prtSep " " trees ++ "}" - prt (TMeta) = "?" - prtList = prtAfter "\n" - -instance (Print s) => Print (ParseForest s) where - prt (FNode s forests) = prt s ++ "^{" ++ prtSep " | " (map (prtSep " ") forests) ++ "}" - prt (FMeta) = "?" - prtList = prtAfter "\n" - - diff --git a/src-3.0/GF/Parsing/CF.hs b/src-3.0/GF/Parsing/CF.hs deleted file mode 100644 index 1a65f6caf..000000000 --- a/src-3.0/GF/Parsing/CF.hs +++ /dev/null @@ -1,66 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Chart parsing of grammars in CF format ------------------------------------------------------------------------------ - -module GF.Parsing.CF (parse) where - -import GF.Data.Operations (errVal) - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Data.SortedList (nubsort) -import GF.Data.Assoc -import qualified GF.CF.CF as CF -import qualified GF.CF.CFIdent as CFI -import GF.Formalism.Utilities -import GF.Formalism.CFG -import qualified GF.Parsing.CFG as P - -type Token = CFI.CFTok -type Name = CFI.CFFun -type Category = CFI.CFCat - -parse :: String -> CF.CF -> Category -> CF.CFParser -parse = buildParser . errVal (errVal undefined (P.parseCF "")) . P.parseCF - -buildParser :: P.CFParser Category Name Token -> CF.CF -> Category -> CF.CFParser -buildParser parser cf start tokens = (parseResults, parseInformation) - where parseInformation = prtSep "\n" trees - parseResults = [ (tree2cfTree t, []) | t <- trees ] - theInput = input tokens - edges = tracePrt "Parsing.CF - nr. edges" (prt.length) $ - parser pInf [start] theInput - chart = tracePrt "Parsing.CF - sz. chart" (prt . map (length.snd) . aAssocs) $ - grammar2chart $ map addCategory edges - forests = tracePrt "Parsing.CF - nr. forests" (prt.length) $ - chart2forests chart (const False) - [ uncurry Edge (inputBounds theInput) start ] - trees = tracePrt "Parsing.CF - nr. trees" (prt.length) $ - concatMap forest2trees forests - pInf = P.buildCFPInfo $ cf2grammar cf (nubsort tokens) - - -addCategory (CFRule cat rhs name) = CFRule cat rhs (name, cat) - -tree2cfTree (TNode (name, Edge _ _ cat) trees) = CF.CFTree (name, (cat, map tree2cfTree trees)) - -cf2grammar :: CF.CF -> [Token] -> CFGrammar Category Name Token -cf2grammar cf tokens = [ CFRule cat rhs name | - (name, (cat, rhs0)) <- cfRules, - rhs <- mapM item2symbol rhs0 ] - where cfRules = concatMap (CF.predefRules (CF.predefOfCF cf)) tokens ++ - CF.rulesOfCF cf - item2symbol (CF.CFNonterm cat) = [Cat cat] - item2symbol item = map Tok $ filter (CF.matchCFTerm item) tokens - - diff --git a/src-3.0/GF/Parsing/CFG.hs b/src-3.0/GF/Parsing/CFG.hs deleted file mode 100644 index f64ce55f1..000000000 --- a/src-3.0/GF/Parsing/CFG.hs +++ /dev/null @@ -1,51 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/11 10:28:16 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- CFG parsing ------------------------------------------------------------------------------ - -module GF.Parsing.CFG - (parseCF, module GF.Parsing.CFG.PInfo) where - -import GF.Data.Operations (Err(..)) - -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Parsing.CFG.PInfo - -import qualified GF.Parsing.CFG.Incremental as Inc -import qualified GF.Parsing.CFG.General as Gen - ----------------------------------------------------------------------- --- parsing - -parseCF :: (Ord n, Ord c, Ord t) => String -> Err (CFParser c n t) - -parseCF "bottomup" = Ok $ Gen.parse bottomup -parseCF "topdown" = Ok $ Gen.parse topdown - -parseCF "gb" = Ok $ Gen.parse bottomup -parseCF "gt" = Ok $ Gen.parse topdown -parseCF "ib" = Ok $ Inc.parse (bottomup, noFilter) -parseCF "it" = Ok $ Inc.parse (topdown, noFilter) -parseCF "ibFT" = Ok $ Inc.parse (bottomup, topdown) -parseCF "ibFB" = Ok $ Inc.parse (bottomup, bottomup) -parseCF "ibFTB" = Ok $ Inc.parse (bottomup, bothFilters) -parseCF "itF" = Ok $ Inc.parse (topdown, bottomup) - --- error parser: -parseCF prs = Bad $ "CFG parsing strategy not defined: " ++ prs - -bottomup = (True, False) -topdown = (False, True) -noFilter = (False, False) -bothFilters = (True, True) - - diff --git a/src-3.0/GF/Parsing/CFG/General.hs b/src-3.0/GF/Parsing/CFG/General.hs deleted file mode 100644 index 4f5959a85..000000000 --- a/src-3.0/GF/Parsing/CFG/General.hs +++ /dev/null @@ -1,103 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:08 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- CFG parsing with a general chart ------------------------------------------------------------------------------ - -module GF.Parsing.CFG.General - (parse, Strategy) where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Parsing.CFG.PInfo -import GF.Data.GeneralDeduction -import GF.Data.Assoc -import Control.Monad - -parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser c n t -parse strategy grammar start = extract . - tracePrt "Parsing.CFG.General - size internal of chart" - (prt . length . chartList) . - process strategy grammar start - --- | parsing strategy: (isBottomup, isTopdown) -type Strategy = (Bool, Bool) - -extract :: (Ord n, Ord c, Ord t) => - IChart n (Symbol c t) -> CFChart c n t -extract chart = [ CFRule (Edge j k cat) daughters name | - Edge j k (Cat cat, found, [], Just name) <- chartList chart, - daughters <- path j k (reverse found) ] - where path i k [] = [ [] | i==k ] - path i k (Tok tok : found) - = [ Tok tok : daughters | - daughters <- path (i+1) k found ] - path i k (Cat cat : found) - = [ Cat (Edge i j cat) : daughters | - Edge _i j _cat <- chartLookup chart (Passive (Cat cat) i), - daughters <- path j k found ] - - -process :: (Ord n, Ord c, Ord t) => - Strategy -- ^ (isBottomup, isTopdown) :: (Bool, Bool) - -> CFPInfo c n t -- ^ parser information (= grammar) - -> [c] -- ^ list of starting categories - -> Input t -- ^ input string - -> IChart n (Symbol c t) -process (isBottomup, isTopdown) grammar start - = trace2 "Parsing.CFG.General - strategy" ((if isBottomup then " BU" else "") ++ - (if isTopdown then " TD" else "")) $ - buildChart keyof [predict, combine] . axioms - where axioms input = initial ++ scan input - - scan input = map (fmap mkEdge) (inputEdges input) - mkEdge tok = (Tok tok, [], [], Nothing) - - -- the combine rule - combine chart (Edge j k (next, _, [], _)) - = [ edge `forwardTo` k | edge <- chartLookup chart (Active next j) ] - combine chart edge@(Edge _ j (_, _, next:_, _)) - = [ edge `forwardTo` k | Edge _ k _ <- chartLookup chart (Passive next j) ] - - -- initial predictions - initial = [ loopingEdge 0 rule | cat <- start, rule <- tdRuleLookup ? cat ] - - -- predictions - predict chart (Edge j k (next, _, [], _)) | isBottomup - = [ loopingEdge j rule `forwardTo` k | rule <- bottomupRules grammar ? next ] - -- - - - - - - - - - ^^^^^^^^^^^^^ Kilbury prediction: move dot forward - predict chart (Edge _ k (_, _, Cat cat:_, _)) - = [ loopingEdge k rule | rule <- tdRuleLookup ? cat ] - predict _ _ = [] - - tdRuleLookup | isTopdown = topdownRules grammar - | isBottomup = emptyLeftcornerRules grammar - --- internal representation of parse items - -type Item n s = Edge (s, [s], [s], Maybe n) -type IChart n s = ParseChart (Item n s) (IKey s) -data IKey s = Active s Int - | Passive s Int - deriving (Eq, Ord, Show) - -keyof (Edge _ j (_, _, next:_, _)) = Active next j -keyof (Edge j _ (cat, _, [], _)) = Passive cat j - -forwardTo (Edge i j (cat, found, next:tofind, name)) k - = Edge i k (cat, next:found, tofind, name) - -loopingEdge k (CFRule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name) - - - diff --git a/src-3.0/GF/Parsing/CFG/Incremental.hs b/src-3.0/GF/Parsing/CFG/Incremental.hs deleted file mode 100644 index adab2b73c..000000000 --- a/src-3.0/GF/Parsing/CFG/Incremental.hs +++ /dev/null @@ -1,150 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Incremental chart parsing for CFG ------------------------------------------------------------------------------ - - -module GF.Parsing.CFG.Incremental - (parse, Strategy) where - -import GF.System.Tracing -import GF.Infra.Print - -import Data.Array - -import GF.Data.Operations -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Parsing.CFG.PInfo -import GF.Data.IncrementalDeduction - - --- | parsing strategy: (predict:(BU, TD), filter:(BU, TD)) -type Strategy = ((Bool, Bool), (Bool, Bool)) - -parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser c n t -parse strategy grammar start = extract . - tracePrt "Parsing.CFG.Incremental - size of internal chart" - (prt . length . flip chartList const) . - process strategy grammar start - -extract :: (Ord n, Ord c, Ord t) => - IChart c n t -> CFChart c n t -extract finalChart = [ CFRule (Edge j k cat) daughters name | - (k, Item j (CFRule cat [] name) found) <- chartList finalChart (,), - daughters <- path j k (reverse found) ] - where path i k [] = [ [] | i==k ] - path i k (Tok tok : found) - = [ Tok tok : daughters | - daughters <- path (i+1) k found ] - path i k (Cat cat : found) - = [ Cat (Edge i j cat) : daughters | - Item j _ _ <- chartLookup finalChart i (Passive cat), - daughters <- path j k found ] - -process :: (Ord n, Ord c, Ord t) => - Strategy -> CFPInfo c n t -> [c] -> Input t -> IChart c n t -process ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input - = trace2 "Parsing.CFG.Incremental - strategy" ((if isPredictBU then "BU-predict " else "") ++ - (if isPredictTD then "TD-predict " else "") ++ - (if isFilterBU then "BU-filter " else "") ++ - (if isFilterTD then "TD-filter " else "")) $ - finalChart - where finalChart = buildChart keyof rules axioms $ inputBounds input - - axioms 0 = union $ map (tdInfer 0) start - axioms k = union [ buInfer j k (Tok token) | - (token, js) <- aAssocs (inputTo input ! k), j <- js ] - - rules k (Item j (CFRule cat [] _) _) - = buInfer j k (Cat cat) - rules k (Item j rule@(CFRule _ (sym@(Cat next):_) _) found) - = tdInfer k next <++> - -- hack for empty rules: - [ Item j (forward rule) (sym:found) | - emptyCategories grammar ?= next ] - rules _ _ = [] - - buInfer j k next = buPredict j k next <++> buCombine j k next - tdInfer k next = tdPredict k next - - -- the combine rule - buCombine j k next - | j == k = [] -- hack for empty rules, see rules above and tdPredict below - | otherwise = [ Item i (forward rule) (next:found) | - Item i rule found <- (finalChart ! j) ? Active next ] - - -- kilbury bottom-up prediction - buPredict j k next - = [ Item j rule [next] | isPredictBU, - rule <- map forward $ bottomupRules grammar ? next, - buFilter rule k, - tdFilter rule j k ] - - -- top-down prediction - tdPredict k cat - = [ Item k rule [] | isPredictTD || isFilterTD, - rule <- topdownRules grammar ? cat, - buFilter rule k ] <++> - -- hack for empty rules: - [ Item k rule [] | isPredictBU, - rule <- emptyLeftcornerRules grammar ? cat ] - - -- bottom up filtering: input symbol k can begin the given symbol list (first set) - -- leftcornerTokens DOESN'T WORK WITH EMPTY RULES!!! - buFilter (CFRule _ (Cat cat:_) _) k | isFilterBU - = k < snd (inputBounds input) && - hasCommonElements (leftcornerTokens grammar ? cat) - (aElems (inputFrom input ! k)) - buFilter _ _ = True - - -- top down filtering: 'cat' is reachable by an active edge ending in node j < k - tdFilter (CFRule cat _ _) j k | isFilterTD && j < k - = (tdFilters ! j) ?= cat - tdFilter _ _ _ = True - - tdFilters = listArray (inputBounds input) $ - map (listSet . limit leftCats . activeCats) [0..] - activeCats j = [ next | Active (Cat next) <- aElems (finalChart ! j) ] - leftCats cat = [ left | CFRule _cat (Cat left:_) _ <- topdownRules grammar ? cat ] - - ----------------------------------------------------------------------- --- type declarations, items & keys - -data Item c n t = Item Int (CFRule c n t) [Symbol c t] - deriving (Eq, Ord, Show) - -data IKey c t = Active (Symbol c t) | Passive c - deriving (Eq, Ord, Show) - -type IChart c n t = IncrementalChart (Item c n t) (IKey c t) - -keyof :: Item c n t -> IKey c t -keyof (Item _ (CFRule _ (next:_) _) _) = Active next -keyof (Item _ (CFRule cat [] _) _) = Passive cat - -forward :: CFRule c n t -> CFRule c n t -forward (CFRule cat (_:rest) name) = CFRule cat rest name - ----------------------------------------------------------------------- - -instance (Print n, Print c, Print t) => Print (Item c n t) where - prt (Item k rule syms) - = "<"++show k++ ": "++ prt rule++" / "++prt syms++">" - -instance (Print c, Print t) => Print (IKey c t) where - prt (Active sym) = "?" ++ prt sym - prt (Passive cat) = "!" ++ prt cat - - diff --git a/src-3.0/GF/Parsing/CFG/PInfo.hs b/src-3.0/GF/Parsing/CFG/PInfo.hs deleted file mode 100644 index f877b225e..000000000 --- a/src-3.0/GF/Parsing/CFG/PInfo.hs +++ /dev/null @@ -1,98 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:45 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- CFG parsing, parser information ------------------------------------------------------------------------------ - -module GF.Parsing.CFG.PInfo - (CFParser, CFPInfo(..), buildCFPInfo) where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Data.SortedList -import GF.Data.Assoc - ----------------------------------------------------------------------- --- type declarations - --- | the list of categories = possible starting categories -type CFParser c n t = CFPInfo c n t - -> [c] - -> Input t - -> CFChart c n t - ------------------------------------------------------------- --- parser information - -data CFPInfo c n t - = CFPInfo { grammarTokens :: SList t, - nameRules :: Assoc n (SList (CFRule c n t)), - topdownRules :: Assoc c (SList (CFRule c n t)), - bottomupRules :: Assoc (Symbol c t) (SList (CFRule c n t)), - emptyLeftcornerRules :: Assoc c (SList (CFRule c n t)), - emptyCategories :: Set c, - cyclicCategories :: SList c, - -- ^ ONLY FOR DIRECT CYCLIC RULES!!! - leftcornerTokens :: Assoc c (SList t) - -- ^ DOES NOT WORK WITH EMPTY RULES!!! - } - -buildCFPInfo :: (Ord c, Ord n, Ord t) => CFGrammar c n t -> CFPInfo c n t - --- this is not permanent... -buildCFPInfo grammar = traceCalcFirst grammar $ - tracePrt "CFG.PInfo - parser info" (prt) $ - pInfo' (filter (not . isCyclic) grammar) - -pInfo' grammar = CFPInfo grToks nmRules tdRules buRules elcRules emptyCats cyclicCats leftToks - where grToks = union [ nubsort [ tok | Tok tok <- rhs ] | - CFRule _ rhs _ <- grammar ] - nmRules = accumAssoc id [ (name, rule) | - rule@(CFRule _ _ name) <- grammar ] - tdRules = accumAssoc id [ (cat, rule) | - rule@(CFRule cat _ _) <- grammar ] - buRules = accumAssoc id [ (next, rule) | - rule@(CFRule _ (next:_) _) <- grammar ] - elcRules = accumAssoc id $ limit lc emptyRules - leftToks = accumAssoc id $ limit lc $ - nubsort [ (cat, token) | - CFRule cat (Tok token:_) _ <- grammar ] - lc (left, res) = nubsort [ (cat, res) | - CFRule cat _ _ <- buRules ? Cat left ] - emptyRules = nubsort [ (cat, rule) | - rule@(CFRule cat [] _) <- grammar ] - emptyCats = listSet $ limitEmpties $ map fst emptyRules - limitEmpties es = if es==es' then es else limitEmpties es' - where es' = nubsort [ cat | CFRule cat rhs _ <- grammar, - all (symbol (\e -> e `elem` es) (const False)) rhs ] - cyclicCats = nubsort [ cat | CFRule cat [Cat cat'] _ <- grammar, cat == cat' ] - -isCyclic (CFRule cat [Cat cat'] _) = cat==cat' -isCyclic _ = False - - ----------------------------------------------------------------------- --- pretty-printing of statistics - -instance (Ord c, Ord n, Ord t) => Print (CFPInfo c n t) where - prt pI = "[ tokens=" ++ sl grammarTokens ++ - "; names=" ++ sla nameRules ++ - "; tdCats=" ++ sla topdownRules ++ - "; buCats=" ++ sla bottomupRules ++ - "; elcCats=" ++ sla emptyLeftcornerRules ++ - "; eCats=" ++ sla emptyCategories ++ - -- "; cCats=" ++ sl cyclicCategories ++ - -- "; lctokCats=" ++ sla leftcornerTokens ++ - " ]" - where sla f = show $ length $ aElems $ f pI - sl f = show $ length $ f pI diff --git a/src-3.0/GF/Parsing/FCFG/Incremental.hs b/src-3.0/GF/Parsing/FCFG/Incremental.hs deleted file mode 100644 index 5ee77a061..000000000 --- a/src-3.0/GF/Parsing/FCFG/Incremental.hs +++ /dev/null @@ -1,107 +0,0 @@ -module GF.Parsing.FCFG.Incremental where - -import Data.Array -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import Control.Monad - -import GF.Data.Assoc -import GF.Data.GeneralDeduction -import GF.Formalism.FCFG -import GF.Formalism.Utilities -import GF.Parsing.FCFG.PInfo -import GF.Parsing.FCFG.Range -import GF.GFCC.CId -import Debug.Trace - -initState :: FCFPInfo -> CId -> State -initState pinfo start = - let items = do - starts <- Map.lookup start (startupCats pinfo) - c <- starts - ruleid <- topdownRules pinfo ? c - let (FRule fn args cat lins) = allRules pinfo ! ruleid - lbl <- indices lins - return (Active 0 lbl 0 ruleid args cat) - - forest = IntMap.fromListWith Set.union [(cat, Set.singleton (Passive ruleid args)) | (ruleid, FRule _ args cat _) <- assocs (allRules pinfo)] - - max_fid = case IntMap.maxViewWithKey forest of - Just ((fid,_), _) -> fid+1 - Nothing -> 0 - - in process pinfo items (State emptyChart [] emptyChart Map.empty forest max_fid 0) - -nextState :: FCFPInfo -> FToken -> State -> State -nextState pinfo t state = - process pinfo (chartLookup (tokens state) t) state{ chart=emptyChart - , charts=chart state : charts state - , tokens=emptyChart - , passive=Map.empty - , currOffset=currOffset state+1 - } - -getCompletions :: State -> FToken -> [FToken] -getCompletions state w = - [t | t <- chartKeys (tokens state), take (length w) t == w] - -process pinfo [] state = state -process pinfo (item@(Active j lbl ppos ruleid args fid0):xitems) state - | inRange (bounds lin) ppos = - case lin ! ppos of - FSymCat _ r d -> let fid = args !! d - in case chartInsert (chart state) item (fid,r) of - Nothing -> process pinfo xitems state - Just actCat -> let items = do exprs <- IntMap.lookup fid (forest state) - (Passive ruleid args) <- Set.toList exprs - return (Active k r 0 ruleid args fid) - `mplus` - do id <- Map.lookup (fid,r,k) (passive state) - return (Active j lbl (ppos+1) ruleid (updateAt d id args) fid0) - in process pinfo (xitems++items) state{chart=actCat} - FSymTok tok -> case chartInsert (tokens state) (Active j lbl (ppos+1) ruleid args fid0) tok of - Nothing -> process pinfo xitems state - Just actTok -> process pinfo xitems state{tokens=actTok} - | otherwise = case Map.lookup (fid0, lbl, j) (passive state) of - Nothing -> let fid = nextId state - items = do Active j' lbl ppos ruleid args fidc <- chartLookup ((chart state:charts state) !! (k-j)) (fid0,lbl) - let FSymCat _ _ d = rhs ruleid lbl ! ppos - return (Active j' lbl (ppos+1) ruleid (updateAt d fid args) fidc) - in process pinfo (xitems++items) state{passive=Map.insert (fid0, lbl, j) fid (passive state) - ,forest =IntMap.insert fid (Set.singleton (Passive ruleid args)) (forest state) - ,nextId =nextId state+1 - } - Just id -> process pinfo xitems state{forest = IntMap.insertWith Set.union id (Set.singleton (Passive ruleid args)) (forest state)} - where - lin = rhs ruleid lbl - k = currOffset state - - rhs ruleid lbl = lins ! lbl - where - (FRule _ _ cat lins) = allRules pinfo ! ruleid - - updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] - - -data Active - = Active Int FIndex FPointPos RuleId [FCat] FCat - deriving (Eq,Show,Ord) -data Passive - = Passive RuleId [FCat] - deriving (Eq,Ord,Show) - - -data State - = State - { chart :: Chart - , charts :: [Chart] - , tokens :: ParseChart Active FToken - , passive :: Map.Map (FCat, FIndex, Int) FCat - , forest :: IntMap.IntMap (Set.Set Passive) - , nextId :: FCat - , currOffset :: Int - } - deriving Show - -type Chart = ParseChart Active (FCat, FIndex) diff --git a/src-3.0/GF/Parsing/GFC.hs b/src-3.0/GF/Parsing/GFC.hs deleted file mode 100644 index 9f1328a50..000000000 --- a/src-3.0/GF/Parsing/GFC.hs +++ /dev/null @@ -1,208 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/13 12:40:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.9 $ --- --- The main parsing module, parsing GFC grammars --- by translating to simpler formats, such as PMCFG and CFG ----------------------------------------------------------------------- - -module GF.Parsing.GFC - (parse, PInfo(..), buildPInfo) where - -import GF.System.Tracing -import GF.Infra.Print -import qualified GF.Grammar.PrGrammar as PrGrammar - -import GF.Data.ErrM - -import qualified GF.Grammar.Grammar as Grammar -import qualified GF.Grammar.Macros as Macros -import qualified GF.Canon.AbsGFC as AbsGFC -import qualified GF.GFCC.DataGFCC as AbsGFCC -import GF.GFCC.CId -import qualified GF.Infra.Ident as Ident -import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok) - -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Formalism.Utilities -import GF.Conversion.Types - -import qualified GF.Formalism.GCFG as G -import qualified GF.Formalism.SimpleGFC as S -import qualified GF.Formalism.MCFG as M -import GF.Formalism.FCFG -import qualified GF.Formalism.CFG as C -import qualified GF.Parsing.MCFG as PM -import qualified GF.Parsing.FCFG as PF -import qualified GF.Parsing.CFG as PC - ----------------------------------------------------------------------- --- parsing information - -data PInfo = PInfo { mcfPInfo :: MCFPInfo - , fcfPInfo :: PF.FCFPInfo - , cfPInfo :: CFPInfo - } - -type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token -type CFPInfo = PC.CFPInfo CCat Name Token - -buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo -buildPInfo mcfg fcfg cfg = PInfo { mcfPInfo = PM.buildMCFPInfo mcfg - , fcfPInfo = PF.buildFCFPInfo fcfg - , cfPInfo = PC.buildCFPInfo cfg - } - -instance Print PInfo where - prt (PInfo m f c) = prt m ++ "\n" ++ prt c - ----------------------------------------------------------------------- --- main parsing function - -parse :: String -- ^ parsing algorithm (mcfg or cfg) - -> String -- ^ parsing strategy - -> PInfo -- ^ compiled grammars (mcfg and cfg) - -> Ident.Ident -- ^ abstract module name - -> CFCat -- ^ starting category - -> [CFTok] -- ^ input tokens - -> Err [Grammar.Term] -- ^ resulting GF terms - - --- parsing via CFG -parse "c" strategy pinfo abs startCat inString - = do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $ - inputMany (map wordsCFTok inString) - let startCats = tracePrt "Parsing.GFC - starting CF categories" prt $ - filter isStart $ map fst $ aAssocs $ PC.topdownRules cfpi - isStart cat = ccat2scat cat == cfCat2Ident startCat - cfpi = cfPInfo pinfo - cfParser <- PC.parseCF strategy - let cfChart = tracePrt "Parsing.GFC - CF chart" (prt . length) $ - cfParser cfpi startCats inTokens - chart = tracePrt "Parsing.GFC - chart" (prt . map (length.snd) . aAssocs) $ - C.grammar2chart cfChart - finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $ - map (uncurry Edge (inputBounds inTokens)) startCats - forests = chart2forests chart (const False) finalEdges - traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests)) - traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees))) - let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $ - forests >>= applyProfileToForest - -- compactFs = tracePrt "#compactForests" (prt . length) $ - -- tracePrt "compactForests" (prtBefore "\n") $ - -- compactForests forests - trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $ - nubsort $ filteredForests >>= forest2trees - -- compactFs >>= forest2trees - return $ map (tree2term abs) trees - - --- parsing via MCFG -parse "m" strategy pinfo abs startCat inString - = do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $ - inputMany (map wordsCFTok inString) - let startCats = tracePrt "Parsing.GFC - starting MCF categories" prt $ - filter isStart $ PM.grammarCats mcfpi - isStart cat = mcat2scat cat == cfCat2Ident startCat - mcfpi = mcfPInfo pinfo - mcfParser <- PM.parseMCF strategy - let chart = mcfParser mcfpi startCats inTokens - finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $ - [ PM.makeFinalEdge cat lbl (inputBounds inTokens) | - cat@(MCat _ [lbl]) <- startCats ] - forests = chart2forests chart (const False) finalEdges - traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests)) - traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees))) - let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $ - forests >>= applyProfileToForest - -- compactFs = tracePrt "#compactForests" (prt . length) $ - -- tracePrt "compactForests" (prtBefore "\n") $ - -- compactForests forests - trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $ - nubsort $ filteredForests >>= forest2trees - -- compactFs >>= forest2trees - return $ map (tree2term abs) trees - - --- parsing via FCFG -parse "f" strategy pinfo abs startCat inString = - let Ident.IC x = cfCat2Ident startCat - cat' = CId x - in case PF.parseFCF strategy (fcfPInfo pinfo) cat' (map prCFTok inString) of - Ok es -> Ok (map (exp2term abs) es) - Bad msg -> Bad msg - - --- error parser: -selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy - -cnv_forests FMeta = FMeta -cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss) -cnv_forests (FString x) = FString x -cnv_forests (FInt x) = FInt x -cnv_forests (FFloat x) = FFloat x - -cnv_profile (Unify x) = Unify x -cnv_profile (Constant x) = Constant (cnv_forests2 x) - -cnv_forests2 FMeta = FMeta -cnv_forests2 (FNode (CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss) -cnv_forests2 (FString x) = FString x -cnv_forests2 (FInt x) = FInt x -cnv_forests2 (FFloat x) = FFloat x - ----------------------------------------------------------------------- --- parse trees to GF terms - -tree2term :: Ident.Ident -> SyntaxTree Fun -> Grammar.Term -tree2term abs (TNode f ts) = Macros.mkApp (Macros.qq (abs,f)) (map (tree2term abs) ts) -tree2term abs (TString s) = Macros.string2term s -tree2term abs (TInt n) = Macros.int2term n -tree2term abs (TFloat f) = Macros.float2term f -tree2term abs (TMeta) = Macros.mkMeta 0 - -exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term -exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings - Macros.mkApp (atom2term abs a) (map (exp2term abs) es) - -atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term -atom2term abs (AbsGFCC.AC (CId f)) = Macros.qq (abs,Ident.IC f) -atom2term abs (AbsGFCC.AS s) = Macros.string2term s -atom2term abs (AbsGFCC.AI n) = Macros.int2term n -atom2term abs (AbsGFCC.AF f) = Macros.float2term f -atom2term abs (AbsGFCC.AM i) = Macros.mkMeta (fromInteger i) - ----------------------------------------------------------------------- --- conversion and unification of forests - --- simplest implementation -applyProfileToForest :: SyntaxForest Name -> [SyntaxForest Fun] -applyProfileToForest (FNode name@(Name fun profile) children) - | isCoercion name = concat chForests - | otherwise = [ FNode fun chForests | not (null chForests) ] - where chForests = concat [ applyProfileM unifyManyForests profile forests | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] -applyProfileToForest (FString s) = [FString s] -applyProfileToForest (FInt n) = [FInt n] -applyProfileToForest (FFloat f) = [FFloat f] -applyProfileToForest (FMeta) = [FMeta] - -{- --- more intelligent(?) implementation -applyProfileToForest (FNode (Name name profile) children) - | isCoercion name = concat chForests - | otherwise = [ FNode name chForests | not (null chForests) ] - where chForests = concat [ mapM (checkProfile forests) profile | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] --} - - diff --git a/src-3.0/GF/Parsing/MCFG.hs b/src-3.0/GF/Parsing/MCFG.hs deleted file mode 100644 index bda3af675..000000000 --- a/src-3.0/GF/Parsing/MCFG.hs +++ /dev/null @@ -1,68 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/11 10:28:16 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG - (parseMCF, module GF.Parsing.MCFG.PInfo) where - -import GF.Data.Operations (Err(..)) - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Parsing.MCFG.PInfo - -import qualified GF.Parsing.MCFG.Naive as Naive -import qualified GF.Parsing.MCFG.Active as Active -import qualified GF.Parsing.MCFG.FastActive as FastActive --- import qualified GF.Parsing.MCFG.Active2 as Active2 -import qualified GF.Parsing.MCFG.Incremental as Incremental --- import qualified GF.Parsing.MCFG.Incremental2 as Incremental2 - ----------------------------------------------------------------------- --- parsing - -parseMCF :: (Ord c, Ord n, Ord l, Ord t) => String -> Err (MCFParser c n l t) -parseMCF prs | prs `elem` strategies = Ok $ parseMCF' prs - | otherwise = Bad $ "MCFG parsing strategy not defined: " ++ prs - - -strategies = words "bottomup topdown n an ab at i rn ran rab rat ri ft fb" - - -parseMCF' :: (Ord c, Ord n, Ord l, Ord t) => String -> MCFParser c n l t - -parseMCF' "bottomup" pinfo starts toks = parseMCF' "fb" pinfo starts toks -parseMCF' "topdown" pinfo starts toks = parseMCF' "ft" pinfo starts toks - -parseMCF' "n" pinfo starts toks = Naive.parse pinfo starts toks -parseMCF' "an" pinfo starts toks = Active.parse "n" pinfo starts toks -parseMCF' "ab" pinfo starts toks = Active.parse "b" pinfo starts toks -parseMCF' "at" pinfo starts toks = Active.parse "t" pinfo starts toks -parseMCF' "i" pinfo starts toks = Incremental.parse pinfo starts toks - --- parseMCF' "an2" pinfo starts toks = Active2.parse "n" pinfo starts toks --- parseMCF' "ab2" pinfo starts toks = Active2.parse "b" pinfo starts toks --- parseMCF' "at2" pinfo starts toks = Active2.parse "t" pinfo starts toks --- parseMCF' "i2" pinfo starts toks = Incremental2.parse pinfo starts toks - -parseMCF' "rn" pinfo starts toks = Naive.parseR (rrP pinfo toks) starts -parseMCF' "ran" pinfo starts toks = Active.parseR "n" (rrP pinfo toks) starts -parseMCF' "rab" pinfo starts toks = Active.parseR "b" (rrP pinfo toks) starts -parseMCF' "rat" pinfo starts toks = Active.parseR "t" (rrP pinfo toks) starts -parseMCF' "ri" pinfo starts toks = Incremental.parseR (rrP pinfo toks) starts ntoks - where ntoks = snd (inputBounds toks) - -parseMCF' "fb" pinfo starts toks = FastActive.parse "b" (rrP pinfo toks) starts -parseMCF' "ft" pinfo starts toks = FastActive.parse "t" (rrP pinfo toks) starts - -rrP pi = rangeRestrictPInfo pi diff --git a/src-3.0/GF/Parsing/MCFG/Active.hs b/src-3.0/GF/Parsing/MCFG/Active.hs deleted file mode 100644 index c6e9c6b06..000000000 --- a/src-3.0/GF/Parsing/MCFG/Active.hs +++ /dev/null @@ -1,318 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing, the active algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Active (parse, parseR) where - -import GF.Data.GeneralDeduction -import GF.Data.Assoc - -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities - -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo - -import GF.System.Tracing - -import Control.Monad (guard) - -import GF.Infra.Print - ----------------------------------------------------------------------- --- * parsing - -parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t -parse strategy pinfo starts toks = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] - where chart = process strategy pinfo starts toks - --- parseR :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t -parseR strategy pinfo starts = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] - where chart = processR strategy pinfo starts - -process :: (Ord n, Ord c, Ord l, Ord t) => - String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l -process strategy pinfo starts toks - = tracePrt "MCFG.Active - chart size" prtSizes $ - buildChart keyof (complete : combine : convert : rules) axioms - where rules | isNil strategy = [scan] - | isBU strategy = [scan, predictKilbury pinfo toks] - | isTD strategy = [scan, predictEarley pinfo toks] - axioms | isNil strategy = predict pinfo toks - | isBU strategy = {- terminal pinfo toks ++ -} initialScan pinfo toks - | isTD strategy = initial pinfo starts toks - ---processR :: (Ord n, Ord c, Ord l) => --- String -> MCFPInfo c n l Range -> [c] -> AChart c n l -processR strategy pinfo starts - = tracePrt "MCFG.Active Range - chart size" prtSizes $ - -- tracePrt "MCFG.Active Range - final chart" prtChart $ - buildChart keyof (complete : combine : convert : rules) axioms - where rules | isNil strategy = [scan] - | isBU strategy = [scan, predictKilburyR pinfo] - | isTD strategy = [scan, predictEarleyR pinfo] - axioms | isNil strategy = predictR pinfo - | isBU strategy = {- terminalR pinfo ++ -} initialScanR pinfo - | isTD strategy = initialR pinfo starts - -isNil s = s=="n" -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: Abstract c n -> [RangeRec l] -emptyChildren (Abs _ rhs _) = replicate (length rhs) [] - -makeMaxRange (Range (_, j)) = Range (j, j) -makeMaxRange EmptyRange = EmptyRange - - ----------------------------------------------------------------------- --- * inference rules - --- completion -complete :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] -complete _ (Active rule found rng (Lin l []) (lin:lins) recs) = - return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs -complete _ _ = [] - --- scanning -scan :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] -scan _ (Active rule found rng (Lin l (Tok rng':syms)) lins recs) = - do rng'' <- concatRange rng rng' - return $ Active rule found rng'' (Lin l syms) lins recs -scan _ _ = [] - --- | Creates an Active Item every time it is possible to combine --- an Active Item from the agenda with a Passive Item from the Chart -combine :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] -combine chart item@(Active _ _ _ (Lin _ (Cat (c,_,_):_)) _ _) = - do Passive _c found <- chartLookup chart (Pass c) - combine2 chart found item -combine chart (Passive c found) = - do item <- chartLookup chart (Act c) - combine2 chart found item -combine _ _ = [] - -combine2 chart found' (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) = - do rng' <- projection r found' - rng'' <- concatRange rng rng' - recs' <- unifyRec recs d found' - return $ Active rule found rng'' (Lin l syms) lins recs' - --- | Active Items with nothing to find are converted to Final items, --- which in turn are converted to Passive Items -convert :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] -convert _ (Active rule found rng (Lin lbl []) [] recs) = - return $ Final rule (found ++ [(lbl,rng)]) recs -convert _ (Final (Abs cat _ _) found _) = - return $ Passive cat found -convert _ _ = [] - - ----------------------------------------------------------------------- --- Naive -- - -predict :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] -predict pinfo toks = tracePrt "MCFG.Active (Naive) - predicted rules" (prt . length) $ - do (Rule abs (Cnc _ _ lins)) <- rulesMatchingInput pinfo toks - (lin':lins') <- rangeRestRec toks lins - return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs) - - ----------------------------------------------------------------------- --- NaiveR -- - -predictR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] -predictR pinfo = tracePrt "MCFG.Active (Naive Range) - predicted rules" (prt . length) $ - do (Rule abs (Cnc _ _ (lin:lins))) <- allRules pinfo - return $ Active abs [] EmptyRange lin lins (emptyChildren abs) - - ----------------------------------------------------------------------- --- Earley -- - --- anropas med alla startkategorier -initial :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> [c] -> Input t -> [Item c n l] -initial pinfo starts toks = - tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $ - do cat <- starts - Rule abs (Cnc _ _ lins) <- topdownRules pinfo ? cat - lin' : lins' <- rangeRestRec toks lins - return $ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs) - -predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t - -> AChart c n l -> Item c n l -> [Item c n l] -predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = - topdownRules pinfo ? cat >>= predictEarley2 toks rng -predictEarley _ _ _ _ = [] - -predictEarley2 :: (Ord c, Ord n, Ord l, Ord t) => Input t -> Range -> MCFRule c n l t -> [Item c n l] -predictEarley2 toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = - do lins' <- rangeRestRec toks lins - return $ Final abs (makeRangeRec lins') [] -predictEarley2 toks rng (Rule abs (Cnc _ _ lins)) = - do lin' : lins' <- rangeRestRec toks lins - return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs) - - ----------------------------------------------------------------------- --- Earley Range -- - -initialR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [c] -> [Item c n l] -initialR pinfo starts = - tracePrt "MCFG.Active (Earley Range) - initial rules" (prt . length) $ - do cat <- starts - Rule abs (Cnc _ _ (lin : lins)) <- topdownRules pinfo ? cat - return $ Active abs [] (Range (0, 0)) lin lins (emptyChildren abs) - -predictEarleyR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range - -> AChart c n l -> Item c n l -> [Item c n l] -predictEarleyR pinfo _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = - topdownRules pinfo ? cat >>= predictEarleyR2 rng -predictEarleyR _ _ _ = [] - -predictEarleyR2 :: (Ord c, Ord n, Ord l) => Range -> MCFRule c n l Range -> [Item c n l] -predictEarleyR2 _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = - return $ Final abs (makeRangeRec lins) [] -predictEarleyR2 rng (Rule abs (Cnc _ _ (lin : lins))) = - return $ Active abs [] EmptyRange lin lins (emptyChildren abs) - - ----------------------------------------------------------------------- --- Kilbury -- - --- terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] --- terminal pinfo toks = --- tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $ --- do Rule abs (Cnc _ _ lins) <- emptyRules pinfo --- lins' <- rangeRestRec toks lins --- return $ Final abs (makeRangeRec lins') [] - -initialScan :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] -initialScan pinfo toks = - tracePrt "MCFG.Active (Kilbury) - initial scanned rules + epsilon rules" (prt . length) $ - do tok <- aElems (inputToken toks) - Rule abs (Cnc _ _ lins) <- - leftcornerTokens pinfo ? tok ++ - epsilonRules pinfo - lin' : lins' <- rangeRestRec toks lins - return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs) - -predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t - -> AChart c n l -> Item c n l -> [Item c n l] -predictKilbury pinfo toks _ (Passive cat found) = - do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat - lin' : lins' <- rangeRestRec toks (Lin l syms : lins) - rng <- projection r found - children <- unifyRec (emptyChildren abs) i found - return $ Active abs [] rng lin' lins' children -predictKilbury _ _ _ _ = [] - - - ----------------------------------------------------------------------- --- KilburyR -- - --- terminalR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] --- terminalR pinfo = --- tracePrt "MCFG.Active (Kilbury Range) - initial terminal rules" (prt . length) $ --- do Rule abs (Cnc _ _ lins) <- emptyRules pinfo --- return $ Final abs (makeRangeRec lins) [] - -initialScanR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] -initialScanR pinfo = - tracePrt "MCFG.Active (Kilbury Range) - initial scanned rules" (prt . length) $ - do Rule abs (Cnc _ _ (lin : lins)) <- - concatMap snd (aAssocs (leftcornerTokens pinfo)) ++ - epsilonRules pinfo - return $ Active abs [] EmptyRange lin lins (emptyChildren abs) - -predictKilburyR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range - -> AChart c n l -> Item c n l -> [Item c n l] -predictKilburyR pinfo _ (Passive cat found) = - do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat - rng <- projection r found - children <- unifyRec (emptyChildren abs) i found - return $ Active abs [] rng (Lin l syms) lins children -predictKilburyR _ _ _ = [] - - ----------------------------------------------------------------------- --- * type definitions - -type AChart c n l = ParseChart (Item c n l) (AKey c) - -data Item c n l = Active (Abstract c n) - (RangeRec l) - Range - (Lin c l Range) - (LinRec c l Range) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] - | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -data AKey c = Act c - | Pass c - | Useless - | Fin - deriving (Eq, Ord, Show) - - -keyof :: Item c n l -> AKey c -keyof (Active _ _ _ (Lin _ (Cat (next, _, _):_)) _ _) = Act next -keyof (Final _ _ _) = Fin -keyof (Passive cat _) = Pass cat -keyof _ = Useless - - ----------------------------------------------------------------------- --- for tracing purposes - -prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++ - ", passive=" ++ show (sum [length (chartLookup chart k) | - k@(Pass _) <- chartKeys chart ]) ++ - ", active=" ++ show (sum [length (chartLookup chart k) | - k@(Act _) <- chartKeys chart ]) ++ - ", useless=" ++ show (length (chartLookup chart Useless)) - -prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ - prtBefore "\n " (chartLookup chart k) | - k <- chartKeys chart ] - -prtFinals chart = prtBefore "\n " (chartLookup chart Fin) - -instance (Print c, Print n, Print l) => Print (Item c n l) where - prt (Active abs found rng lin tofind children) = - "? " ++ prt abs ++ ";\n\t" ++ - "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ - prt lin ++ " {" ++ prtSep " " tofind ++ "}" ++ - ( if null children then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) - prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" - prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ - ( if null rrs then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) - -instance Print c => Print (AKey c) where - prt (Act c) = "Active " ++ prt c - prt (Pass c) = "Passive " ++ prt c - prt (Fin) = "Final" - prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/Active2.hs b/src-3.0/GF/Parsing/MCFG/Active2.hs deleted file mode 100644 index 7ad8627bc..000000000 --- a/src-3.0/GF/Parsing/MCFG/Active2.hs +++ /dev/null @@ -1,237 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- MCFG parsing, the active algorithm (alternative version) ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Active2 (parse) where - -import GF.Data.GeneralDeduction -import GF.Data.Assoc - -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities - -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo - -import GF.System.Tracing - -import Control.Monad (guard) - -import GF.Infra.Print - ----------------------------------------------------------------------- --- * parsing - ---parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t -parse strategy pinfo starts toks = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] - where chart = process strategy pinfo starts toks - -process :: (Ord n, Ord c, Ord l, Ord t) => - String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l t -process strategy pinfo starts toks - = tracePrt "MCFG.Active - chart size" prtSizes $ - buildChart keyof (complete : combine : convert : rules) axioms - where rules | isNil strategy = [scan toks] - | isBU strategy = [scan toks, predictKilbury pinfo toks] - | isTD strategy = [scan toks, predictEarley pinfo toks] - axioms | isNil strategy = predict pinfo toks - | isBU strategy = terminal pinfo toks ++ initialScan pinfo toks - | isTD strategy = initial pinfo starts toks - -isNil s = s=="n" -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: Abstract c n -> [RangeRec l] -emptyChildren (Abs _ rhs _) = replicate (length rhs) [] - -makeMaxRange (Range (_, j)) = Range (j, j) -makeMaxRange EmptyRange = EmptyRange - - ----------------------------------------------------------------------- --- * inference rules - --- completion -complete :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] -complete _ (Active rule found rng (Lin l []) (lin:lins) recs) = - return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs -complete _ _ = [] - --- scanning ---scan :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] -scan inp _ (Active rule found rng (Lin l (Tok tok:syms)) lins recs) = - do rng' <- map makeRange (inputToken inp ? tok) - rng'' <- concatRange rng rng' - return $ Active rule found rng'' (Lin l syms) lins recs -scan _ _ _ = [] - --- | Creates an Active Item every time it is possible to combine --- an Active Item from the agenda with a Passive Item from the Chart -combine :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] -combine chart item@(Active _ _ _ (Lin _ (Cat (c,_,_):_)) _ _) = - do Passive _c found <- chartLookup chart (Pass c) - combine2 chart found item -combine chart (Passive c found) = - do item <- chartLookup chart (Act c) - combine2 chart found item -combine _ _ = [] - -combine2 chart found' (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) = - do rng' <- projection r found' - rng'' <- concatRange rng rng' - recs' <- unifyRec recs d found' - return $ Active rule found rng'' (Lin l syms) lins recs' - --- | Active Items with nothing to find are converted to Final items, --- which in turn are converted to Passive Items -convert :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] -convert _ (Active rule found rng (Lin lbl []) [] recs) = - return $ Final rule (found ++ [(lbl,rng)]) recs -convert _ (Final (Abs cat _ _) found _) = - return $ Passive cat found -convert _ _ = [] - - ----------------------------------------------------------------------- --- Naive -- - -predict :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t] -predict pinfo toks = tracePrt "MCFG.Active (Naive) - predicted rules" (prt . length) $ - do Rule abs (Cnc _ _ (lin:lins)) <- rulesMatchingInput pinfo toks - return $ Active abs [] EmptyRange lin lins (emptyChildren abs) - - ----------------------------------------------------------------------- --- Earley -- - --- anropas med alla startkategorier -initial :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> [c] -> Input t -> [Item c n l t] -initial pinfo starts toks = - tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $ - do cat <- starts - Rule abs (Cnc _ _ (lin:lins)) <- topdownRules pinfo ? cat - return $ Active abs [] (Range (0, 0)) lin lins (emptyChildren abs) - -predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t - -> AChart c n l t -> Item c n l t -> [Item c n l t] -predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = - topdownRules pinfo ? cat >>= predictEarley2 toks rng -predictEarley _ _ _ _ = [] - -predictEarley2 :: (Ord c, Ord n, Ord l, Ord t) => Input t -> Range -> MCFRule c n l t -> [Item c n l t] -predictEarley2 toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = - do lins' <- rangeRestRec toks lins - return $ Final abs (makeRangeRec lins') [] -predictEarley2 toks rng (Rule abs (Cnc _ _ (lin:lins))) = - return $ Active abs [] EmptyRange lin lins (emptyChildren abs) - - ----------------------------------------------------------------------- --- Kilbury -- - -terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t] -terminal pinfo toks = - tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $ - do Rule abs (Cnc _ _ lins) <- emptyRules pinfo - lins' <- rangeRestRec toks lins - return $ Final abs (makeRangeRec lins') [] - -initialScan :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t] -initialScan pinfo toks = - tracePrt "MCFG.Active (Kilbury) - initial scanned rules" (prt . length) $ - do tok <- aElems (inputToken toks) - Rule abs (Cnc _ _ (lin:lins)) <- leftcornerTokens pinfo ? tok - return $ Active abs [] EmptyRange lin lins (emptyChildren abs) - -predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t - -> AChart c n l t -> Item c n l t -> [Item c n l t] -predictKilbury pinfo toks _ (Passive cat found) = - do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat - rng <- projection r found - children <- unifyRec (emptyChildren abs) i found - return $ Active abs [] rng (Lin l syms) lins children -predictKilbury _ _ _ _ = [] - - ----------------------------------------------------------------------- --- * type definitions - -type AChart c n l t = ParseChart (Item c n l t) (AKey c t) - -data Item c n l t = Active (Abstract c n) - (RangeRec l) - Range - (Lin c l t) - (LinRec c l t) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] - | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -data AKey c t = Act c - | ActTok t - | Pass c - | Useless - | Fin - deriving (Eq, Ord, Show) - - -keyof :: Item c n l t -> AKey c t -keyof (Active _ _ _ (Lin _ (Cat (next, _, _):_)) _ _) = Act next -keyof (Active _ _ _ (Lin _ (Tok tok:_)) _ _) = ActTok tok -keyof (Final _ _ _) = Fin -keyof (Passive cat _) = Pass cat -keyof _ = Useless - - ----------------------------------------------------------------------- --- for tracing purposes - -prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++ - ", passive=" ++ show (sum [length (chartLookup chart k) | - k@(Pass _) <- chartKeys chart ]) ++ - ", active=" ++ show (sum [length (chartLookup chart k) | - k@(Act _) <- chartKeys chart ]) ++ - ", active-tok=" ++ show (sum [length (chartLookup chart k) | - k@(ActTok _) <- chartKeys chart ]) ++ - ", useless=" ++ show (length (chartLookup chart Useless)) - -prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ - prtBefore "\n " (chartLookup chart k) | - k <- chartKeys chart ] - -prtFinals chart = prtBefore "\n " (chartLookup chart Fin) - -instance (Print c, Print n, Print l, Print t) => Print (Item c n l t) where - prt (Active abs found rng lin tofind children) = - "? " ++ prt abs ++ ";\n\t" ++ - "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ - prt lin ++ " {" ++ prtSep " " tofind ++ "}" ++ - ( if null children then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) - prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" - prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ - ( if null rrs then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) - -instance (Print c, Print t) => Print (AKey c t) where - prt (Act c) = "Active " ++ prt c - prt (ActTok t) = "Active-Tok " ++ prt t - prt (Pass c) = "Passive " ++ prt c - prt (Fin) = "Final" - prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/FastActive.hs b/src-3.0/GF/Parsing/MCFG/FastActive.hs deleted file mode 100644 index 0a8e24b55..000000000 --- a/src-3.0/GF/Parsing/MCFG/FastActive.hs +++ /dev/null @@ -1,176 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- MCFG parsing, the active algorithm, optimized version --- structure stolen from Krasimir Angelov's GF.Parsing.FCFG.Active ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.FastActive (parse) where - -import GF.Data.GeneralDeduction -import GF.Data.Assoc -import GF.Data.Utilities - -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities - -import GF.Infra.Ident - -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo - -import GF.System.Tracing - -import Control.Monad (guard) - -import GF.Infra.Print - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Array - ----------------------------------------------------------------------- --- * parsing - --- parse :: (Ord c, Ord n, Ord l, Ord t) => String -> MCFParser c n l t -parse strategy pinfo starts = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- listXChartFinal chart ] - where chart = process strategy pinfo axioms emptyXChart - - -- axioms | isBU strategy = terminal pinfo toks ++ initialScan pinfo toks - axioms | isBU strategy = initialBU pinfo - | isTD strategy = initialTD pinfo starts - -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: Abstract c n -> [RangeRec l] -emptyChildren (Abs _ rhs _) = replicate (length rhs) [] - -updateChildren :: Eq l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]] -updateChildren recs i rec = updateNthM update i recs - where update rec' = do guard (null rec' || rec' == rec) - return rec - -process :: (Ord c, Ord n, Ord l) => String -> MCFPInfo c n l Range -> [Item c n l] -> XChart c n l -> XChart c n l -process strategy pinfo [] chart = chart -process strategy pinfo (item:items) chart = process strategy pinfo items $! univRule item chart - where - univRule item@(Active abs found rng (Lin l syms) lins recs) chart - = case syms of - Cat(c,r,d) : syms' -> - case insertXChart chart item c of - Nothing -> chart - Just chart -> - let items = -- predict topdown - [ Active abs [] EmptyRange lin lins (emptyChildren abs) | - isTD strategy, - Rule abs (Cnc _ _ (lin:lins)) <- topdownRules pinfo ? c ] ++ - - -- combine - [ Active abs found rng'' (Lin l syms') lins recs' | - Final _ found' _ <- lookupXChartFinal chart c, - rng' <- projection r found', - rng'' <- concatRange rng rng', - recs' <- updateChildren recs d found' ] - in process strategy pinfo items chart - - -- scan - Tok rng' : syms' -> - let items = [ Active abs found rng'' (Lin l syms') lins recs | - rng'' <- concatRange rng rng' ] - in process strategy pinfo items chart - - -- complete - [] -> case lins of - (lin':lins') -> univRule (Active abs ((l,rng):found) EmptyRange lin' lins' recs) chart - [] -> univRule (Final abs (reverse ((l,rng):found)) recs) chart - - univRule item@(Final abs@(Abs cat _ _) found' recs) chart = - case insertXChart chart item cat of - Nothing -> chart - Just chart -> - let items = -- predict bottomup - [ Active abs [] rng (Lin l syms') lins children | - isBU strategy, - Rule abs (Cnc _ _ (Lin l (Cat(c,r,d):syms') : lins)) <- leftcornerCats pinfo ? cat, - -- lin' : lins' <- rangeRestRec toks (Lin l syms' : lins), - rng <- projection r found', - children <- unifyRec (emptyChildren abs) d found' ] ++ - - -- combine - [ Active abs found rng'' (Lin l syms') lins recs' | - Active abs found rng (Lin l (Cat(c,r,d):syms')) lins recs <- lookupXChartAct chart cat, - rng' <- projection r found', - rng'' <- concatRange rng rng', - recs' <- updateChildren recs d found' ] - in process strategy pinfo items chart - ----------------------------------------------------------------------- --- * XChart - -data XChart c n l = XChart !(AChart c n l) !(AChart c n l) -type AChart c n l = ParseChart (Item c n l) c - -data Item c n l = Active (Abstract c n) - (RangeRec l) - Range - (Lin c l Range) - (LinRec c l Range) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] --- | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -emptyXChart :: (Ord c, Ord n, Ord l) => XChart c n l -emptyXChart = XChart emptyChart emptyChart - -insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _) c = - case chartInsert actives item c of - Nothing -> Nothing - Just actives -> Just (XChart actives finals) - -insertXChart (XChart actives finals) item@(Final _ _ _) c = - case chartInsert finals item c of - Nothing -> Nothing - Just finals -> Just (XChart actives finals) - -lookupXChartAct (XChart actives finals) c = chartLookup actives c -lookupXChartFinal (XChart actives finals) c = chartLookup finals c - -listXChartAct (XChart actives finals) = chartList actives -listXChartFinal (XChart actives finals) = chartList finals - - ----------------------------------------------------------------------- --- Earley -- - --- called with all starting categories -initialTD :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [c] -> [Item c n l] -initialTD pinfo starts = - [ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs) | - cat <- starts, - Rule abs (Cnc _ _ (lin':lins')) <- topdownRules pinfo ? cat ] - -- lin' : lins' <- rangeRestRec toks lins - - ----------------------------------------------------------------------- --- Kilbury -- - -initialBU :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] -initialBU pinfo = - [ Active abs [] EmptyRange lin' lins' (emptyChildren abs) | - -- do tok <- aElems (inputToken toks) - Rule abs (Cnc _ _ (lin':lins')) <- - concatMap snd (aAssocs (leftcornerTokens pinfo)) ++ - -- leftcornerTokens pinfo ? tok ++ - epsilonRules pinfo ] - -- lin' : lins' <- rangeRestRec toks lins diff --git a/src-3.0/GF/Parsing/MCFG/Incremental.hs b/src-3.0/GF/Parsing/MCFG/Incremental.hs deleted file mode 100644 index bd5b4114d..000000000 --- a/src-3.0/GF/Parsing/MCFG/Incremental.hs +++ /dev/null @@ -1,178 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- MCFG parsing, the incremental algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Incremental (parse, parseR) where - -import Data.List -import Control.Monad (guard) - -import GF.Data.Utilities (select) -import GF.Data.GeneralDeduction -import GF.Data.Assoc - -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities - -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo - -import GF.System.Tracing -import GF.Infra.Print - ----------------------------------------------------------------------- --- parsing - -parse :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t -parse pinfo starts toks = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] - where chart = process pinfo toks ntoks - ntoks = snd (inputBounds toks) - --- parseR :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t -parseR pinfo starts ntoks = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] - where chart = processR pinfo ntoks - -process :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> IChart c n l -process pinfo toks ntoks - = tracePrt "MCFG.Incremental - chart size" prtSizes $ - buildChart keyof [complete ntoks, scan, combine, convert] (predict pinfo toks ntoks) - -processR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> Int -> IChart c n l -processR pinfo ntoks - = tracePrt "MCFG.Incremental Range - chart size" prtSizes $ - buildChart keyof [complete ntoks, scan, combine, convert] (predictR pinfo ntoks) - -complete :: (Ord n, Ord c, Ord l) => Int -> IChart c n l -> Item c n l -> [Item c n l] -complete ntoks _ (Active rule found rng (Lin l []) lins recs) = - do (lin, lins') <- select lins - k <- [minRange rng .. ntoks] - return $ Active rule (found ++ [(l, rng)]) (Range (k,k)) lin lins' recs -complete _ _ _ = [] - - -predict :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> [Item c n l] -predict pinfo toks n = - tracePrt "MCFG.Incremental - predicted rules" (prt . length) $ - do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo toks - let daughters = replicate (length rhs) [] - lins' <- rangeRestRec toks lins - (lin', lins'') <- select lins' - k <- [0..n] - return $ Active abs [] (Range (k,k)) lin' lins'' daughters - - -predictR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> Int -> [Item c n l] -predictR pinfo n = - tracePrt "MCFG.Incremental Range - predicted rules" (prt . length) $ - do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- allRules pinfo - let daughters = replicate (length rhs) [] - (lin, lins') <- select lins - k <- [0..n] - return $ Active abs [] (Range (k,k)) lin lins' daughters - - -scan :: (Ord n, Ord c, Ord l) => IChart c n l -> Item c n l -> [Item c n l] -scan _ (Active abs found rng (Lin l (Tok rng':syms)) lins recs) = - do rng'' <- concatRange rng rng' - return $ Active abs found rng'' (Lin l syms) lins recs -scan _ _ = [] - - -combine :: (Ord n, Ord c, Ord l) => IChart c n l -> Item c n l -> [Item c n l] -combine chart active@(Active _ _ rng (Lin _ (Cat (c,l,_):_)) _ _) = - do passive <- chartLookup chart (Pass c l (maxRange rng)) - combine2 active passive -combine chart passive@(Active (Abs c _ _) _ rng (Lin l []) _ _) = - do active <- chartLookup chart (Act c l (minRange rng)) - combine2 active passive -combine _ _ = [] - -combine2 (Active abs found rng (Lin l (Cat (c,l',d):syms)) lins recs) - (Active _ found' rng' _ _ _) - = do rng'' <- concatRange rng rng' - recs' <- unifyRec recs d found'' - return $ Active abs found rng'' (Lin l syms) lins recs' - where found'' = found' ++ [(l',rng')] - - -convert _ (Active rule found rng (Lin lbl []) [] recs) = - return $ Final rule (found ++ [(lbl,rng)]) recs -convert _ _ = [] - ----------------------------------------------------------------------- --- type definitions - -type IChart c n l = ParseChart (Item c n l) (IKey c l) - -data Item c n l = Active (Abstract c n) - (RangeRec l) - Range - (Lin c l Range) - (LinRec c l Range) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] --- | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -data IKey c l = Act c l Int - | Pass c l Int - | Useless - | Fin - deriving (Eq, Ord, Show) - -keyof :: Item c n l -> IKey c l -keyof (Active _ _ rng (Lin _ (Cat (next,lbl,_):_)) _ _) - = Act next lbl (maxRange rng) -keyof (Active (Abs cat _ _) found rng (Lin lbl []) _ _) - = Pass cat lbl (minRange rng) -keyof (Final _ _ _) = Fin -keyof _ - = Useless - - ----------------------------------------------------------------------- --- for tracing purposes -prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++ - ", passive=" ++ show (sum [length (chartLookup chart k) | - k@(Pass _ _ _) <- chartKeys chart ]) ++ - ", active=" ++ show (sum [length (chartLookup chart k) | - k@(Act _ _ _) <- chartKeys chart ]) ++ - ", useless=" ++ show (length (chartLookup chart Useless)) - -prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ - prtBefore "\n " (chartLookup chart k) | - k <- chartKeys chart ] - -instance (Print c, Print n, Print l) => Print (Item c n l) where - prt (Active abs found rng lin tofind children) = - "? " ++ prt abs ++ ";\n\t" ++ - "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ - prt lin ++ "{" ++ prtSep " " tofind ++ "}" ++ - ( if null children then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) --- prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" - prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ - ( if null rrs then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) - -instance (Print c, Print l) => Print (IKey c l) where - prt (Act c l i) = "Active " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i - prt (Pass c l i) = "Passive " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i - prt (Fin) = "Final" - prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/Incremental2.hs b/src-3.0/GF/Parsing/MCFG/Incremental2.hs deleted file mode 100644 index db6c3084e..000000000 --- a/src-3.0/GF/Parsing/MCFG/Incremental2.hs +++ /dev/null @@ -1,157 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- MCFG parsing, the incremental algorithm (alternative version) ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Incremental2 (parse) where - -import Data.List -import Data.Array -import Control.Monad (guard) - -import GF.Data.Utilities (select) -import GF.Data.Assoc -import GF.Data.IncrementalDeduction - -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities - -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo - -import GF.System.Tracing -import GF.Infra.Print - ----------------------------------------------------------------------- --- parsing - --- parseR :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t -parse pinfo starts inp = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - k <- uncurry enumFromTo (inputBounds inp), - Final (Abs cat rhs fun) found rrecs <- chartLookup chart k Fin ] - where chart = process pinfo inp - ---process :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> (Int, Int) -> IChart c n l -process pinfo inp - = tracePrt "MCFG.Incremental - chart size" - (prt . map (prtSizes finalChart . fst) . assocs) $ - finalChart - where finalChart = buildChart keyof rules axioms inBounds - axioms k = tracePrt ("MCFG.Incremental - axioms for " ++ show k) (prt . length) $ - predict k ++ scan k ++ complete1 k - rules k item = complete2 k item ++ combine k item ++ convert k item - inBounds = inputBounds inp - - -- axioms: predict + scan + complete - predict k = do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo inp - let daughters = replicate (length rhs) [] - (lin, lins') <- select lins - return $ Active abs [] k lin lins' daughters - - scan k = do (tok, js) <- aAssocs (inputTo inp ! k) - j <- js - Active abs found i (Lin l (Tok _tok:syms)) lins recs <- - chartLookup finalChart j (ActTok tok) - return $ Active abs found i (Lin l syms) lins recs - - complete1 k = do j <- [fst inBounds .. k-1] - Active abs found i (Lin l _Nil) lins recs <- - chartLookup finalChart j Pass - let found' = found ++ [(l, makeRange (i,j))] - (lin, lins') <- select lins - return $ Active abs found' k lin lins' recs - - -- rules: convert + combine + complete - convert k (Active rule found j (Lin lbl []) [] recs) = - let found' = found ++ [(lbl, makeRange (j,k))] - in return $ Final rule found' recs - convert _ _ = [] - - combine k (Active (Abs cat _ _) found' j (Lin lbl []) _ _) = - do guard (j < k) ---- cannot handle epsilon-rules - Active abs found i (Lin l (Cat (_cat,_lbl,nr):syms)) lins recs <- - chartLookup finalChart j (Act cat lbl) - let found'' = found' ++ [(lbl, makeRange (j,k))] - recs' <- unifyRec recs nr found'' - return $ Active abs found i (Lin l syms) lins recs' - combine _ _ = [] - - complete2 k (Active abs found i (Lin l []) lins recs) = - do let found' = found ++ [(l, makeRange (i,k))] - (lin, lins') <- select lins - return $ Active abs found' k lin lins' recs - complete2 _ _ = [] - ----------------------------------------------------------------------- --- type definitions - -type IChart c n l t = IncrementalChart (Item c n l t) (IKey c l t) - -data Item c n l t = Active (Abstract c n) - (RangeRec l) - Int - (Lin c l t) - (LinRec c l t) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] - ---- | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -data IKey c l t = Act c l - | ActTok t - ---- | Useless - | Pass - | Fin - deriving (Eq, Ord, Show) - -keyof :: Item c n l t -> IKey c l t -keyof (Active _ _ _ (Lin _ (Cat (next,lbl,_):_)) _ _) = Act next lbl -keyof (Active _ _ _ (Lin _ (Tok tok:_)) _ _) = ActTok tok -keyof (Active _ _ _ (Lin _ []) _ _) = Pass -keyof (Final _ _ _) = Fin --- keyof _ = Useless - - ----------------------------------------------------------------------- --- for tracing purposes -prtSizes chart k = "f=" ++ show (length (chartLookup chart k Fin)) ++ - " p=" ++ show (length (chartLookup chart k Pass)) ++ - " a=" ++ show (sum [length (chartLookup chart k key) | - key@(Act _ _) <- chartKeys chart k ]) ++ - " t=" ++ show (sum [length (chartLookup chart k key) | - key@(ActTok _) <- chartKeys chart k ]) - -- " u=" ++ show (length (chartLookup chart k Useless)) - --- prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ --- prtBefore "\n " (chartLookup chart k) | --- k <- chartKeys chart ] - -instance (Print c, Print n, Print l, Print t) => Print (Item c n l t) where - prt (Active abs found rng lin tofind children) = - "? " ++ prt abs ++ ";\n\t" ++ - "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ - prt lin ++ "{" ++ prtSep " " tofind ++ "}" ++ - ( if null children then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) - -- prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" - prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ - ( if null rrs then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) - -instance (Print c, Print l, Print t) => Print (IKey c l t) where - prt (Act c l) = "Active " ++ prt c ++ " " ++ prt l - prt (ActTok t) = "ActiveTok " ++ prt t - -- prt (Pass c l i) = "Passive " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i - prt (Fin) = "Final" - -- prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/Naive.hs b/src-3.0/GF/Parsing/MCFG/Naive.hs deleted file mode 100644 index 7d1fa0a8a..000000000 --- a/src-3.0/GF/Parsing/MCFG/Naive.hs +++ /dev/null @@ -1,142 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing, the naive algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Naive (parse, parseR) where - -import Control.Monad (guard) - --- GF modules -import GF.Data.GeneralDeduction -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo -import GF.Data.SortedList -import GF.Data.Assoc -import GF.System.Tracing - -import GF.Infra.Print - ----------------------------------------------------------------------- --- * parsing - --- | Builds a chart from the initial agenda, given by prediction, and the inference rules -parse :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t -parse pinfo starts toks - = accumAssoc groupSyntaxNodes $ - [ ((cat, makeRangeRec lins), SNode fun (zip rhs rrecs)) | - Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ] - where chart = process pinfo toks - --- | Builds a chart from the initial agenda, given by prediction, and the inference rules --- parseR :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t -parseR pinfo starts - = accumAssoc groupSyntaxNodes $ - [ ((cat, makeRangeRec lins), SNode fun (zip rhs rrecs)) | - Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ] - where chart = processR pinfo - -process :: (Ord t, Ord n, Ord c, Ord l) => MCFPInfo c n l t -> Input t -> NChart c n l -process pinfo toks - = tracePrt "MCFG.Naive - chart size" prtSizes $ - buildChart keyof [convert, combine] (predict pinfo toks) - -processR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> NChart c n l -processR pinfo - = tracePrt "MCFG.Naive Range - chart size" prtSizes $ - buildChart keyof [convert, combine] (predictR pinfo) - - ----------------------------------------------------------------------- --- * inference rules - --- Creates an Active Item of every Rule in the Grammar to give the initial Agenda -predict :: (Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] -predict pinfo toks = tracePrt "MCFG.Naive - predicted rules" (prt . length) $ - do Rule abs (Cnc _ _ lins) <- rulesMatchingInput pinfo toks - lins' <- rangeRestRec toks lins - return $ Active (abs, []) lins' [] - --- Creates an Active Item of every Rule in the Grammar to give the initial Agenda -predictR :: (Ord l) => MCFPInfo c n l Range -> [Item c n l] -predictR pinfo = tracePrt "MCFG.Naive Range - predicted rules" (prt . length) $ - do Rule abs (Cnc _ _ lins) <- allRules pinfo - return $ Active (abs, []) lins [] - --- | Creates an Active Item every time it is possible to combine --- an Active Item from the agenda with a Passive Item from the Chart -combine :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l] -combine chart item@(Active (Abs _ (c:_) _, _) _ _) = - do Passive _c rrec <- chartLookup chart (Pass c) - combine2 chart rrec item -combine chart (Passive c rrec) = - do item <- chartLookup chart (Act c) - combine2 chart rrec item -combine _ _ = [] - -combine2 chart rrec (Active (Abs nt (c:find) f, found) lins rrecs) = - do lins' <- substArgRec (length found) rrec lins - return $ Active (Abs nt find f, found ++ [c]) lins' (rrecs ++ [rrec]) - --- | Active Items with nothing to find are converted to Passive Items -convert :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l] -convert _ (Active (Abs cat [] fun, _) lins _) = [Passive cat (makeRangeRec lins)] -convert _ _ = [] - - ----------------------------------------------------------------------- --- * type definitions - -type NChart c n l = ParseChart (Item c n l) (NKey c) - -data Item c n l = Active (DottedRule c n) (LinRec c l Range) [RangeRec l] - | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -type DottedRule c n = (Abstract c n, [c]) - -data NKey c = Act c - | Pass c - | Final - deriving (Eq, Ord, Show) - -keyof :: Item c n l -> NKey c -keyof (Active (Abs _ (next:_) _, _) _ _) = Act next -keyof (Passive cat _) = Pass cat -keyof _ = Final - --- for tracing purposes -prtSizes chart = "final=" ++ show (length (chartLookup chart Final)) ++ - ", passive=" ++ show (sum [length (chartLookup chart k) | - k@(Pass _) <- chartKeys chart ]) ++ - ", active=" ++ show (sum [length (chartLookup chart k) | - k@(Act _) <- chartKeys chart ]) - -prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ - prtBefore "\n " (chartLookup chart k) | - k <- chartKeys chart ] - -instance (Print c, Print n, Print l) => Print (Item c n l) where - prt (Active (abs, cs) lrec rrecs) = "? " ++ prt abs ++ " . " ++ prtSep " " cs ++ ";\n\t" ++ - "{" ++ prtSep " " lrec ++ "}" ++ - ( if null rrecs then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") rrecs) ++ "}" ) - prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" - -instance Print c => Print (NKey c) where - prt (Act c) = "Active " ++ prt c - prt (Pass c) = "Passive " ++ prt c - prt (Final) = "Final" - - diff --git a/src-3.0/GF/Parsing/MCFG/PInfo.hs b/src-3.0/GF/Parsing/MCFG/PInfo.hs deleted file mode 100644 index 56119dcec..000000000 --- a/src-3.0/GF/Parsing/MCFG/PInfo.hs +++ /dev/null @@ -1,162 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/13 12:40:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing, parser information ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.PInfo where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Parsing.MCFG.Range - ----------------------------------------------------------------------- --- type declarations - --- | the list of categories = possible starting categories -type MCFParser c n l t = MCFPInfo c n l t - -> [c] - -> Input t - -> SyntaxChart n (c, RangeRec l) - -makeFinalEdge :: c -> l -> (Int, Int) -> (c, RangeRec l) -makeFinalEdge cat lbl bnds = (cat, [(lbl, makeRange bnds)]) - - ------------------------------------------------------------- --- parser information - -data MCFPInfo c n l t - = MCFPInfo { grammarTokens :: SList t - , nameRules :: Assoc n (SList (MCFRule c n l t)) - , topdownRules :: Assoc c (SList (MCFRule c n l t)) - -- ^ used in 'GF.Parsing.MCFG.Active' (Earley): - , epsilonRules :: [MCFRule c n l t] - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , leftcornerCats :: Assoc c (SList (MCFRule c n l t)) - , leftcornerTokens :: Assoc t (SList (MCFRule c n l t)) - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , grammarCats :: SList c - -- ^ used when calculating starting categories - , rulesByToken :: Assoc t (SList (MCFRule c n l t, SList t)) - , rulesWithoutTokens :: SList (MCFRule c n l t) - -- ^ used by 'rulesMatchingInput' - , allRules :: MCFGrammar c n l t - -- ^ used by any unoptimized algorithm - - --bottomupRules :: Assoc (Symbol c t) (SList (CFRule c n t)), - --emptyLeftcornerRules :: Assoc c (SList (CFRule c n t)), - --emptyCategories :: Set c, - } - - -rangeRestrictPInfo :: (Ord c, Ord n, Ord l, Ord t) => - MCFPInfo c n l t -> Input t -> MCFPInfo c n l Range -rangeRestrictPInfo (pinfo{-::MCFPInfo c n l t-}) inp = - tracePrt "MCFG.PInfo - Restricting the parser information" (prt . grammarTokens) - MCFPInfo { grammarTokens = nubsort (map edgeRange (inputEdges inp)) - , nameRules = rrAssoc (nameRules pinfo) - , topdownRules = rrAssoc (topdownRules pinfo) - , epsilonRules = rrRules (epsilonRules pinfo) - , leftcornerCats = rrAssoc (leftcornerCats pinfo) - , leftcornerTokens = lctokens - , grammarCats = grammarCats pinfo - , rulesByToken = emptyAssoc -- error "MCFG.PInfo.rulesByToken - no range restriction" - , rulesWithoutTokens = [] -- error "MCFG.PInfo.rulesByToken - no range restriction" - , allRules = allrules -- rrRules (allRules pinfo) - } - - where lctokens = accumAssoc id - [ (rng, rule) | (tok, rules) <- aAssocs (leftcornerTokens pinfo), - inputToken inp ?= tok, - rule@(Rule _ (Cnc _ _ (Lin _ (Tok rng:_) : _))) - <- concatMap (rangeRestrictRule inp) rules ] - - allrules = rrRules $ rulesMatchingInput pinfo inp - - rrAssoc assoc = filterNull $ fmap rrRules assoc - filterNull assoc = assocFilter (not . null) assoc - rrRules rules = concatMap (rangeRestrictRule inp) rules - - -buildMCFPInfo :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> MCFPInfo c n l t -buildMCFPInfo grammar = - traceCalcFirst grammar $ - tracePrt "MCFG.PInfo - parser info" (prt) $ - MCFPInfo { grammarTokens = grammartokens - , nameRules = namerules - , topdownRules = topdownrules - , epsilonRules = epsilonrules - , leftcornerCats = leftcorncats - , leftcornerTokens = leftcorntoks - , grammarCats = grammarcats - , rulesByToken = rulesbytoken - , rulesWithoutTokens = ruleswithouttokens - , allRules = allrules - } - - where allrules = concatMap expandVariants grammar - grammartokens = union (map fst ruletokens) - namerules = accumAssoc id - [ (name, rule) | rule@(Rule (Abs _ _ name) _) <- allrules ] - topdownrules = accumAssoc id - [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- allrules ] - epsilonrules = [ rule | rule@(Rule _ (Cnc _ _ (Lin _ [] : _))) <- allrules ] - leftcorncats = accumAssoc id - [ (cat, rule) | - rule@(Rule _ (Cnc _ _ (Lin _ (Cat(cat,_,_):_) : _))) <- allrules ] - leftcorntoks = accumAssoc id - [ (tok, rule) | - rule@(Rule _ (Cnc _ _ (Lin _ (Tok tok:_) : _))) <- allrules ] - grammarcats = aElems topdownrules - ruletokens = [ (toksoflins lins, rule) | - rule@(Rule _ (Cnc _ _ lins)) <- allrules ] - toksoflins lins = nubsort [ tok | Lin _ syms <- lins, Tok tok <- syms ] - rulesbytoken = accumAssoc id - [ (tok, (rule, toks)) | (tok:toks, rule) <- ruletokens ] - ruleswithouttokens = nubsort [ rule | ([], rule) <- ruletokens ] - - --- | return only the rules for which all tokens are in the input string -rulesMatchingInput :: Ord t => MCFPInfo c n l t -> Input t -> [MCFRule c n l t] -rulesMatchingInput pinfo inp = - [ rule | tok <- toks, - (rule, ruletoks) <- rulesByToken pinfo ? tok, - ruletoks `subset` toks ] - ++ rulesWithoutTokens pinfo - where toks = aElems (inputToken inp) - - ----------------------------------------------------------------------- --- pretty-printing of statistics - -instance (Ord c, Ord n, Ord l, Ord t) => Print (MCFPInfo c n l t) where - prt pI = "[ tokens=" ++ sl grammarTokens ++ - "; categories=" ++ sl grammarCats ++ - "; nameRules=" ++ sla nameRules ++ - "; tdRules=" ++ sla topdownRules ++ - "; epsilonRules=" ++ sl epsilonRules ++ - "; lcCats=" ++ sla leftcornerCats ++ - "; lcTokens=" ++ sla leftcornerTokens ++ - "; byToken=" ++ sla rulesByToken ++ - "; noTokens=" ++ sl rulesWithoutTokens ++ - "; allRules=" ++ sl allRules ++ - " ]" - - where sl f = show $ length $ f pI - sla f = let (as, bs) = unzip $ aAssocs $ f pI - in show (length as) ++ "/" ++ show (length (concat bs)) - diff --git a/src-3.0/GF/Parsing/MCFG/Range.hs b/src-3.0/GF/Parsing/MCFG/Range.hs deleted file mode 100644 index 91671fa00..000000000 --- a/src-3.0/GF/Parsing/MCFG/Range.hs +++ /dev/null @@ -1,206 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- Definitions of ranges, and operations on ranges ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Range - ( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange, - LinRec, RangeRec, - makeRangeRec, rangeRestRec, rangeRestrictRule, - projection, unifyRec, substArgRec - ) where - - --- Haskell -import Data.List -import Control.Monad - --- GF modules -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities -import GF.Infra.Print -import GF.Data.Assoc ((?)) -import GF.Data.Utilities (updateNthM) - ------------------------------------------------------------- --- ranges as single pairs - -data Range = Range (Int, Int) - | EmptyRange - deriving (Eq, Ord, Show) - -makeRange :: (Int, Int) -> Range -concatRange :: Range -> Range -> [Range] -rangeEdge :: a -> Range -> Edge a -edgeRange :: Edge a -> Range -minRange :: Range -> Int -maxRange :: Range -> Int - -makeRange = Range -concatRange EmptyRange rng = return rng -concatRange rng EmptyRange = return rng -concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j'] -rangeEdge a (Range(i,j)) = Edge i j a -edgeRange (Edge i j _) = Range (i,j) -minRange (Range rho) = fst rho -maxRange (Range rho) = snd rho - -instance Print Range where - prt (Range (i,j)) = "(" ++ show i ++ "-" ++ show j ++ ")" - prt (EmptyRange) = "(?)" - -{-- Types -------------------------------------------------------------------- - Linearization- and Range records implemented as lists ------------------------------------------------------------------------------} - -type LinRec c l t = [Lin c l t] - -type RangeRec l = [(l, Range)] - - -{-- Functions ---------------------------------------------------------------- - Concatenation : Concatenation of Ranges, Symbols and Linearizations - and records of Linearizations - Record transformation : Makes a Range record from a fully instantiated - Linearization record - Record projection : Given a label, returns the corresponding Range - Range restriction : Range restriction of Tokens, Symbols, - Linearizations and Records given a list of Tokens - Record replacment : Substitute a record for another in a list of Range - records - Argument substitution : Substitution of a Cat c to a Tok Range, where - Range is the cover of c - Note: The argument is still a Symbol c Range - Subsumation : Checks if a Range record subsumes another Range - record - Record unification : Unification of two Range records ------------------------------------------------------------------------------} - - ---- Concatenation ------------------------------------------------------------ - - -concSymbols :: [Symbol c Range] -> [[Symbol c Range]] -concSymbols (Tok rng:Tok rng':toks) = do rng'' <- concatRange rng rng' - concSymbols (Tok rng'':toks) -concSymbols (sym:syms) = do syms' <- concSymbols syms - return (sym:syms') -concSymbols [] = return [] - - -concLin :: Lin c l Range -> [Lin c l Range] -concLin (Lin lbl syms) = do syms' <- concSymbols syms - return (Lin lbl syms') - - -concLinRec :: LinRec c l Range -> [LinRec c l Range] -concLinRec = mapM concLin - - ---- Record transformation ---------------------------------------------------- - -makeRangeRec :: LinRec c l Range -> RangeRec l -makeRangeRec lins = map convLin lins - where convLin (Lin lbl [Tok rng]) = (lbl, rng) - convLin (Lin lbl []) = (lbl, EmptyRange) - convLin _ = error "makeRangeRec" - - ---- Record projection -------------------------------------------------------- - -projection :: Ord l => l -> RangeRec l -> [Range] -projection l rec = maybe (fail "projection") return $ lookup l rec - - ---- Range restriction -------------------------------------------------------- - -rangeRestTok :: Ord t => Input t -> t -> [Range] -rangeRestTok toks tok = do rng <- inputToken toks ? tok - return (makeRange rng) - - -rangeRestSym :: Ord t => Input t -> Symbol a t -> [Symbol a Range] -rangeRestSym toks (Tok tok) = do rng <- rangeRestTok toks tok - return (Tok rng) -rangeRestSym _ (Cat c) = return (Cat c) - - -rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range] -rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms - concLin (Lin lbl syms') - -- return (Lin lbl syms') - - -rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range] -rangeRestRec toks = mapM (rangeRestLin toks) - - -rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range] -rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $ - rangeRestRec toks lins - ---- Argument substitution ---------------------------------------------------- - -substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range - -> Symbol (c, l, Int) Range -substArgSymbol i rec tok@(Tok rng) = tok -substArgSymbol i rec cat@(Cat (c, l, j)) - | i==j = maybe err Tok $ lookup l rec - | otherwise = cat - where err = error "substArg: Label not in range-record" - -substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range - -> [Lin c l Range] -substArgLin i rec (Lin lbl syms) = - concLin (Lin lbl (map (substArgSymbol i rec) syms)) - - -substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range - -> [LinRec c l Range] -substArgRec i rec lins = mapM (substArgLin i rec) lins - - --- Record unification & replacment --------------------------------------------------------- - -unifyRec :: Ord l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]] -unifyRec recs i rec = updateNthM update i recs - where update rec' = guard (subsumes rec' rec) >> return rec - --- unifyRec recs i rec = do guard $ subsumes (recs !! i) rec --- return $ replaceRec recs i rec - -replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l] -replaceRec recs i rec = before ++ (rec : after) - where (before, _ : after) = splitAt i recs - -subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool -subsumes rec rec' = and [r `elem` rec' | r <- rec] --- subsumes rec rec' = all (`elem` rec') rec - - -{- ---- Record unification ------------------------------------------------------- -unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]] -unifyRangeRecs recs recs' = zipWithM unify recs recs' - where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l] - unify rec [] = return rec - unify [] rec = return rec - unify rec1'@(p1@(l1, r1):rec1) rec2'@(p2@(l2, r2):rec2) - = case compare l1 l2 of - LT -> do rec3 <- unify rec1 rec2' - return (p1:rec3) - GT -> do rec3 <- unify rec1' rec2 - return (p2:rec3) - EQ -> do guard (r1 == r2) - rec3 <- unify rec1 rec2 - return (p1:rec3) --} diff --git a/src-3.0/GF/Parsing/MCFG/ViaCFG.hs b/src-3.0/GF/Parsing/MCFG/ViaCFG.hs deleted file mode 100644 index 9204ea9f1..000000000 --- a/src-3.0/GF/Parsing/MCFG/ViaCFG.hs +++ /dev/null @@ -1,186 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- MCFG parsing, through context-free approximation ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.ViaCFG where - - --- Haskell modules -import Data.List -import Control.Monad - --- GF modules -import ConvertMCFGtoDecoratedCFG -import qualified DecoratedCFParser as CFP -import qualified DecoratedGrammar as CFG -import Examples -import GF.OldParsing.GeneralChart -import qualified GF.OldParsing.MCFGrammar as MCFG -import MCFParser -import Nondet -import Parser -import GF.Parsing.MCFG.Range - - -{-- Datatypes ----------------------------------------------------------------- -Chart -Item -Key - - - Item : Four different Items are used. PreMCFG for MCFG Pre Items, Pre are - the Items returned by the pre-Functions and Mark are the - corresponding Items for the mark-Functions. For convenience correctly - marked Mark Items are converted to Passive Items. -I use dottedrule for convenience to keep track of wich daughter's RangeRec to look for. - AChart: A RedBlackMap with Items and Keys - AKey : -------------------------------------------------------------------------------} - ---Ev ta bort några typer av Item och bara nyckla på det som är unikt för den typen... -data Item n c l = PreMCFG (n, c) (RangeRec l) [RangeRec l] - | Pre (n, c) (RangeRec l) [l] [RangeRec l] - | Mark (n, c) (RangeRec l) (RangeRec l) [RangeRec l] - | Passive (n, c) (RangeRec l) (RangeRec l) - deriving (Eq, Ord, Show) - -type AChart n c l = ParseChart (Item n c l) (AKey n c l) - -data AKey n c l = Pr (n, c) l - | Pm (n, c) l - | Mk (RangeRec l) - | Ps (RangeRec l) - | Useless - deriving (Eq, Ord, Show) - - -{-- Parsing ------------------------------------------------------------------- - recognize: - parse : The Agenda consists of the Passive Items from context-free - approximation (as PreMCFG Items) and the Pre Items inferred by - pre-prediction. - keyof : Given an Item returns an appropriate Key for the Chart -------------------------------------------------------------------------------} - -recognize strategy mcfg toks = chartMember (parse strategy mcfg toks) - (Passive ("f", S) - [("s" , MCFG.Range (0, n))] - [("p" , MCFG.Range (0, n2)), ("q", MCFG.Range (n2, n))]) - (Ps [("s" , MCFG.Range (0, n))]) - where n = length toks - n2 = n `div` 2 - - ---parse :: (Ord n, Ord NT, Ord String, Eq t) => CFP.Strategy -> MCFG.Grammar n NT String t -> [t] --- -> AChart n NT String -parse strategy mcfg toks - = buildChart keyof - [preCombine, markPredict, markCombine, convert] - (makePreItems (CFP.parse strategy (CFG.pInfo (convertGrammar mcfg)) [(S, "s")] toks) ++ - (prePredict mcfg)) - - -keyof :: Item n c l -> AKey n c l -keyof (PreMCFG head [(lbl, rng)] _) = Pm head lbl -keyof (Pre head _ (lbl:lbls) _) = Pr head lbl -keyof (Mark _ _ _ (rec:recs)) = Mk rec -keyof (Passive _ rec _) = Ps rec -keyof _ = Useless - - -{-- Initializing agenda ------------------------------------------------------- - makePreItems: -------------------------------------------------------------------------------} - -makePreItems :: (Eq c, Ord i) => CFG.Grammar n (Edge (c, l)) i t -> [Item n c l] -makePreItems cfchart - = [ PreMCFG (fun, cat) [(lbl, MCFG.makeRange (i, j))] (symToRec beta) | - CFG.Rule (Edge i j (cat,lbl)) beta fun <- cfchart ] - - -prePredict :: (Ord n, Ord c, Ord l) => MCFG.Grammar n c l t -> [Item n c l] -prePredict mcfg = - [ Pre (f, nt) [] (getLables lins) (replicate (nrOfCats (head lins)) []) | - MCFG.Rule nt nts lins f <- mcfg ] - - -{-- Inference rules --------------------------------------------------------- - prePredict : - preCombine : - markPredict: - markCombine: - convert : -----------------------------------------------------------------------------} - -preCombine :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -preCombine chart (Pre head rec (l:ls) recs) = - [ Pre head (rec ++ [(l, r)]) ls recs'' | - PreMCFG head [(l, r)] recs' <- chartLookup chart (Pm head l), - recs'' <- solutions (unifyRangeRecs recs recs') ] -preCombine chart (PreMCFG head [(l, r)] recs) = - [ Pre head (rec ++ [(l, r)]) ls recs'' | - Pre head rec (l:ls) recs' <- chartLookup chart (Pr head l), - recs'' <- solutions (unifyRangeRecs recs recs') ] -preCombine _ _ = [] - - -markPredict :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -markPredict _ (Pre (n, c) rec [] recs) = [Mark (n, c) rec [] recs] -markPredict _ _ = [] - - -markCombine :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -markCombine chart (Mark (f, c) rec mRec (r:recs)) = - [ Mark (f, c) rec (mRec ++ r) recs | - Passive _ r _ <- chartLookup chart (Ps r)] -markCombine chart (Passive _ r _) = - [ Mark (f, c) rec (mRec++r) recs | - Mark (f, c) rec mRec (r:recs) <- chartLookup chart (Mk r) ] -markCombine _ _ = [] - - -convert :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -convert _ (Mark (f, c) r rec []) = [Passive (f, c) r rec] -convert _ _ = [] - - -{-- Help functions ---------------------------------------------------------------- - getRHS : - getLables: - symToRec : -----------------------------------------------------------------------------------} - --- FULKOD ! -nrOfCats :: Eq c => MCFG.Lin c l t -> Int -nrOfCats (MCFG.Lin l syms) = length $ nub [(c, i) | Cat (c, l, i) <- syms] - - --- -getLables :: LinRec c l t -> [l] -getLables lins = [l | MCFG.Lin l syms <- lins] - - --- -symToRec :: Ord i => [Symbol (Edge (c, l), i) d] -> [[(l, MCFG.Range)]] -symToRec beta = map makeLblRng $ groupBy (\(_, d) (_, d') -> (d == d')) - $ sortBy sBd [(Edge i j (c, l) , d) | Cat (Edge i j (c, l), d) - <- beta] - where makeLblRng edges = [(l, (MCFG.makeRange (i, j))) | (Edge i j (_, l), _) - <- edges] - sBd (_, d) (_, d') - | d < d' = LT - | d > d' = GT - | otherwise = EQ diff --git a/src-3.0/GF/Printing/PrintParser.hs b/src-3.0/GF/Printing/PrintParser.hs deleted file mode 100644 index d9041ecaa..000000000 --- a/src-3.0/GF/Printing/PrintParser.hs +++ /dev/null @@ -1,83 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrintParser --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Pretty-printing of parser objects ------------------------------------------------------------------------------ - -module GF.Printing.PrintParser (Print(..), - prtBefore, prtAfter, prtSep, - prtBeforeAfter, - prIO - ) where - --- haskell modules: -import Data.List (intersperse) --- gf modules: -import GF.Data.Operations (Err(..)) -import GF.Infra.Ident (Ident(..)) -import qualified GF.Canon.PrintGFC as P - ------------------------------------------------------------- - -prtBefore :: Print a => String -> [a] -> String -prtBefore before = prtBeforeAfter before "" - -prtAfter :: Print a => String -> [a] -> String -prtAfter after = prtBeforeAfter "" after - -prtSep :: Print a => String -> [a] -> String -prtSep sep = concat . intersperse sep . map prt - -prtBeforeAfter :: Print a => String -> String -> [a] -> String -prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ] - -prIO :: Print a => a -> IO () -prIO = putStr . prt - -class Print a where - prt :: a -> String - prtList :: [a] -> String - prtList as = "[" ++ prtSep "," as ++ "]" - -instance Print a => Print [a] where - prt = prtList - -instance (Print a, Print b) => Print (a, b) where - prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")" - -instance (Print a, Print b, Print c) => Print (a, b, c) where - prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")" - -instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where - prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")" - -instance Print Char where - prt = return - prtList = id - -instance Print Int where - prt = show - -instance Print Integer where - prt = show - -instance Print a => Print (Maybe a) where - prt (Just a) = "!" ++ prt a - prt Nothing = "Nothing" - -instance Print a => Print (Err a) where - prt (Ok a) = prt a - prt (Bad str) = str - -instance Print Ident where - prt ident = str - where str = P.printTree ident - diff --git a/src-3.0/GF/Printing/PrintSimplifiedTerm.hs b/src-3.0/GF/Printing/PrintSimplifiedTerm.hs deleted file mode 100644 index ccd107558..000000000 --- a/src-3.0/GF/Printing/PrintSimplifiedTerm.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrintSimplifiedTerm --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 14:15:19 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Instances for printing terms in a simplified format ------------------------------------------------------------------------------ - - -module GF.Printing.PrintSimplifiedTerm () where - -import GF.Canon.AbsGFC -import GF.CF.CF -import GF.CF.CFIdent -import GF.Printing.PrintParser -import qualified GF.Canon.PrintGFC as P - -instance Print Term where - prt (Arg arg) = prt arg - prt (con `Par` []) = prt con - prt (con `Par` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")" - prt (LI ident) = prt ident - prt (R record) = "{" ++ prtSep ";" record ++ "}" - prt (term `P` lbl) = prt term ++ "." ++ prt lbl - prt (T _ table) = "table{" ++ prtSep ";" table ++ "}" - prt (term `S` sel) = prt term ++ "!" ++ prt sel - prt (FV terms) = "variants{" ++ prtSep "|" terms ++ "}" - prt (term `C` term') = prt term ++ " " ++ prt term' - prt (K tokn) = show (prt tokn) - prt (E) = show "" - -instance Print Patt where - prt (con `PC` []) = prt con - prt (con `PC` pats) = prt con ++ "(" ++ prtSep "," pats ++ ")" - prt (PV ident) = prt ident - prt (PW) = "_" - prt (PR record) = "{" ++ prtSep ";" record ++ "}" - -instance Print Label where - prt (L ident) = prt ident - prt (LV nr) = "$" ++ show nr - -instance Print Tokn where - prt (KS str) = str - prt tokn@(KP _ _) = show tokn - -instance Print ArgVar where - prt (A cat argNr) = prt cat ++ "#" ++ show argNr - -instance Print CIdent where - prt (CIQ _ ident) = prt ident - -instance Print Case where - prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term - -instance Print Assign where - prt (lbl `Ass` term) = prt lbl ++ "=" ++ prt term - -instance Print PattAssign where - prt (lbl `PAss` pat) = prt lbl ++ "=" ++ prt pat - -instance Print Atom where - prt (AC c) = prt c - prt (AD c) = "<" ++ prt c ++ ">" - prt (AV i) = "$" ++ prt i - prt (AM n) = "?" ++ show n - prt (AS s) = show s - prt (AI n) = show n - prt (AT s) = show s - -instance Print CType where - prt (RecType rtype) = "{" ++ prtSep ";" rtype ++ "}" - prt (Table ptype vtype) = "(" ++ prt ptype ++ "=>" ++ prt vtype ++ ")" - prt (Cn cn) = prt cn - prt (TStr) = "Str" - -instance Print Labelling where - prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype - -instance Print CFItem where - prt (CFTerm regexp) = prt regexp - prt (CFNonterm cat) = prt cat - -instance Print RegExp where - prt (RegAlts words) = "("++prtSep "|" words ++ ")" - prt (RegSpec tok) = prt tok - -instance Print CFTok where - prt (TS str) = str - prt tok = show tok - -instance Print CFCat where - prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl - -instance Print CFFun where - prt (CFFun fun) = prt (fst fun) - -instance Print Exp where - prt = P.printTree - - -sizeCT :: CType -> Int -sizeCT (RecType rt) = 1 + sum [ sizeCT t | _ `Lbg` t <- rt ] -sizeCT (Table pt vt) = 1 + sizeCT pt + sizeCT vt -sizeCT (Cn cn) = 1 -sizeCT (TStr) = 1 - -sizeT :: Term -> Int -sizeT (_ `Par` ts) = 2 + sum (map sizeT ts) -sizeT (R rec) = 1 + sum [ sizeT t | _ `Ass` t <- rec ] -sizeT (t `P` _) = 1 + sizeT t -sizeT (T _ tbl) = 1 + sum [ sum (map sizeP ps) + sizeT t | ps `Cas` t <- tbl ] -sizeT (t `S` s) = 1 + sizeT t + sizeT s -sizeT (t `C` t') = 1 + sizeT t + sizeT t' -sizeT (FV ts) = 1 + sum (map sizeT ts) -sizeT _ = 1 - -sizeP :: Patt -> Int -sizeP (con `PC` pats) = 2 + sum (map sizeP pats) -sizeP (PR record) = 1 + sum [ sizeP p | _ `PAss` p <- record ] -sizeP _ = 1 diff --git a/src-3.0/GF/Probabilistic/Probabilistic.hs b/src-3.0/GF/Probabilistic/Probabilistic.hs deleted file mode 100644 index 25258db52..000000000 --- a/src-3.0/GF/Probabilistic/Probabilistic.hs +++ /dev/null @@ -1,203 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Probabilistic --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 09:20:09 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.5 $ --- --- Probabilistic abstract syntax. AR 30\/10\/2005 --- --- (c) Aarne Ranta 2005 under GNU GPL --- --- Contents: parsing and random generation with probabilistic grammars. --- To begin with, we use simple types and don't --- guarantee the correctness of bindings\/dependences. ------------------------------------------------------------------------------ - -module GF.Probabilistic.Probabilistic ( - generateRandomTreesProb -- :: Options -> StdGen -> GFCGrammar -> Probs -> Cat -> [Exp] - ,checkGrammarProbs -- :: GFCGrammar -> Probs -> Err () - ,computeProbTree -- :: Probs -> Tree -> Double - ,rankByScore -- :: Ord n => [(a,n)] -> [(a,n)] - ,Probs -- = BinTree Ident Double - ,getProbsFromFile -- :: Opts -> IO Probs - ,emptyProbs -- :: Probs - ,prProbs -- :: Probs -> String - ) 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 -import GF.Grammar.SGrammar - -import GF.Infra.Ident -import GF.Data.Zipper -import GF.Data.Operations -import GF.Infra.Option - -import Data.Char -import Data.List -import Control.Monad -import System.Random - --- | this parameter tells how many constructors at most are generated in a tree -timeout :: Int -timeout = 99 - --- | generate an infinite list of trees, with their probabilities -generateRandomTreesProb :: Options -> StdGen -> GFCGrammar -> Probs -> Cat -> [Exp] -generateRandomTreesProb opts gen gr probs cat = - map str2tr $ randomTrees gen gr' cat' where - gr' = gr2sgr opts probs gr - cat' = prt $ snd cat - --- | check that probabilities attached to a grammar make sense -checkGrammarProbs :: GFCGrammar -> Probs -> Err Probs -checkGrammarProbs gr probs = - err Bad (return . gr2probs) $ checkSGrammar $ gr2sgr noOptions probs gr where - gr2probs sgr = buildTree [(zIdent f,p) | (_,rs) <- tree2list sgr, ((p,f),_) <- rs] - --- | compute the probability of a given tree -computeProbTree :: Probs -> Tree -> Double -computeProbTree probs (Tr (N (_,at,_,_,_),ts)) = case at of - AtC (_,f) -> case lookupTree prt f probs of - Ok p -> p * product (map prob ts) - _ -> product (map prob ts) - _ -> 1.0 ---- - where - prob = computeProbTree probs - --- | rank from highest to lowest score, e.g. probability -rankByScore :: Ord n => [(a,n)] -> [(a,n)] -rankByScore = sortBy (\ (_,p) (_,q) -> compare q p) - -getProbsFromFile :: Options -> FilePath -> IO Probs -getProbsFromFile opts file = do - s <- maybe (readFile file) readFile $ getOptVal opts probFile - return $ buildTree $ concatMap pProb $ lines s --- where -pProb s = case words s of - "--#":"prob":f:p:_ | isDouble p -> [(zIdent f, read p)] - f:ps@(g:rest) -> case span (/= "--#") ps of - (_,_:"prob":p:_) | isDouble p -> [(zIdent f', readD p)] where - f' = if elem f ["fun","lin","data"] then ident g else ident f - _ -> [] - _ -> [] - where - isDouble = all (flip elem ('.':['0'..'9'])) - ident = takeWhile (flip notElem ".:") - readD :: String -> Double - readD = read - ------------------------------------------- --- translate grammar to simpler form and generated trees back - -probTree :: STree -> Double -probTree t = case t of - SApp ((p,_),ts) -> p * product (map probTree ts) - _ -> 1 - -rankTrees :: [STree] -> [(STree,Double)] -rankTrees ts = sortBy (\ (_,p) (_,q) -> compare q p) [(t,probTree t) | t <- ts] - -randomTrees :: StdGen -> SGrammar -> SCat -> [STree] -randomTrees gen = genTrees (randomRs (0.0, 1.0) gen) - -genTrees :: [Double] -> SGrammar -> SCat -> [STree] -genTrees ds0 gr cat = - let (ds,ds2) = splitAt (timeout+1) ds0 -- for time out, else ds - (t,k) = genTree ds gr cat - in (if k>timeout then id else (t:)) -- don't accept with metas - (genTrees ds2 gr cat) -- else (drop k ds) - -genTree :: [Double] -> SGrammar -> SCat -> (STree,Int) -genTree rs gr = gett rs where - gett [] cat = (SMeta cat,1) -- time-out case - gett ds "String" = (SString "foo",1) - gett ds "Int" = (SInt 1978,1) - gett ds "Float" = (SFloat 3.1415926, 1) - gett ds cat = case look cat of - [] -> (SMeta cat,1) -- if no productions, return ? - fs -> let - d:ds2 = ds - (pf,args) = getf d fs - (ts,k) = getts ds2 args - in (SApp (pf,ts), k+1) - getf d fs = hitRegion d [(p,(pf,args)) | (pf@(p,_),(args,_)) <- fs] - getts ds cats = case cats of - c:cs -> let - (t, k) = gett ds c - (ts,ks) = getts (drop k ds) cs - in (t:ts, k + ks) - _ -> ([],0) - look cat = errVal [] $ lookupTree id cat gr - -hitRegion :: Double -> [(Double,a)] -> a -hitRegion d vs = case vs of - (p1,v1):vs2 -> - if d < p1 then v1 else hitRegion d [(p+p1,v) | (p,v) <- vs2] - ---- this should recover from rounding errors - -checkSGrammar :: SGrammar -> Err SGrammar -checkSGrammar = mapMTree chCat where - chCat (c,rs) = case sum [p | ((p,f),_) <- rs] of - s | abs (s - 1.0) > 0.01 -> - Bad $ "illegal probability sum " ++ show s ++ " in " ++ c - _ -> return (c,rs) - - -{- ------------------------------------------- --- to test outside GF - -prSTree t = case t of - SApp ((p,f),ts) -> f ++ prParenth (show p) ++ concat (map pr1 ts) - SMeta c -> '?':c - SString s -> prQuotedString s - SInt i -> show i - SFloat i -> show i - where - pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t) - pr1 t = prSTree t - - -mkSGrammar :: [SRule] -> SGrammar -mkSGrammar rules = - buildTree [(c, fillProb rs) | rs@((_,(_,c)):_) <- rules'] where - rules' = - groupBy (\x y -> scat x == scat y) $ - sortBy (\x y -> compare (scat x) (scat y)) - rules - scat (_,(_,c)) = c - -pSRule :: String -> SRule -pSRule s = case words s of - p : f : c : cs -> - if isDigit (head p) - then ((read p, f),(init cs', last cs')) - else ((2.0, p),(init (c:cs'), last (c:cs'))) --- hack for automatic probability - where cs' = [cs !! i | i <- [0,2..length cs - 1]] - _ -> error $ "not a rule" +++ s - -expSgr = mkSGrammar $ map pSRule [ - "0.8 a : A" - ,"0.2 b : A" - ,"0.2 n : A -> S -> S" - ,"0.8 e : S" - ] - -ex1 :: IO () -ex1 = do - g <- newStdGen - mapM_ (putStrLn . prSTree) $ randomTrees g exSgr "S" - --} - diff --git a/src-3.0/GF/Shell.hs b/src-3.0/GF/Shell.hs deleted file mode 100644 index 1d723bc62..000000000 --- a/src-3.0/GF/Shell.hs +++ /dev/null @@ -1,591 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Shell --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/07 20:15:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.50 $ --- --- GF shell command interpreter. ------------------------------------------------------------------------------ - -module GF.Shell where - ---- abstract away from these? -import GF.Data.Str -import qualified GF.Grammar.Grammar as G -import qualified GF.Infra.Ident as I -import qualified GF.Grammar.Compute as Co -import qualified GF.Compile.CheckGrammar as Ch -import qualified GF.Grammar.Lookup as L -import qualified GF.Canon.GFC as GFC -import qualified GF.Canon.Look as Look -import qualified GF.Canon.CMacros as CMacros -import qualified GF.Grammar.MMacros as MMacros -import qualified GF.Compile.GrammarToCanon as GrammarToCanon -import GF.Grammar.Values -import GF.UseGrammar.GetTree -import GF.UseGrammar.Generate (generateAll) ---- should be in API -import GF.UseGrammar.Treebank -import GF.UseGrammar.TreeSelections (getOverloadResults) - -import GF.Shell.ShellCommands - -import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSourceGrammar) -import GF.Visualization.VisualizeTree (visualizeTrees) -import GF.API -import GF.API.IOGrammar -import GF.Compile.Compile ----- import GFTex -import GF.Shell.TeachYourself -- also a subshell - -import GF.UseGrammar.Randomized --- -import GF.UseGrammar.Editing (goFirstMeta) --- - -import GF.Probabilistic.Probabilistic - -import GF.Compile.ShellState -import GF.Infra.Option -import GF.UseGrammar.Information -import GF.Shell.HelpFile -import GF.Compile.PrOld -import GF.Compile.Wordlist -import GF.Grammar.PrGrammar - -import Control.Monad (foldM,liftM) -import System (system) -import System.IO (hPutStrLn, stderr) -import System.Random (newStdGen) ---- -import Data.List (nub,isPrefixOf) -import GF.Data.Zipper ---- - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Text.UTF8 (encodeUTF8) -import Data.Char (isDigit) -import Data.Maybe (fromMaybe) - -import GF.System.Signal (runInterruptibly) -import System.Exit (exitFailure) -import System.FilePath - ----- import qualified GrammarToGramlet as Gr ----- import qualified GrammarToCanonXML2 as Canon - --- AR 18/4/2000 - 7/11/2001 - --- data Command moved to ShellCommands. AR 27/5/2004 - -type CommandLine = (CommandOpt, CommandArg, [CommandOpt]) - --- | term as returned by the command parser -type SrcTerm = G.Term - --- | history & CPU -type HState = (ShellState,([String],Integer,ShMacros,ShTerms)) - -type ShMacros = [(String,[String])] -- dc %c = ... #1 ... #2 ... -type ShTerms = [(String,Tree)] -- dt $e = f ... - -type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg) - -initHState :: ShellState -> HState -initHState st = (st,([],0,[],[])) - -cpuHState :: HState -> Integer -cpuHState (_,(_,i,_,_)) = i - -optsHState :: HState -> Options -optsHState (st,_) = globalOptions st - -putHStateCPU :: Integer -> HState -> HState -putHStateCPU cpu (st,(h,_,c,t)) = (st,(h,cpu,c,t)) - -updateHistory :: String -> HState -> HState -updateHistory s (st,(h,cpu,c,t)) = (st,(s:h,cpu,c,t)) - -addShMacro :: (String,[String]) -> HState -> HState -addShMacro m (st,(h,cpu,c,t)) = (st,(h,cpu,m:c,t)) - -addShTerm :: (String,Tree) -> HState -> HState -addShTerm m (st,(h,cpu,c,t)) = (st,(h,cpu,c,m:t)) - -resolveShMacro :: HState -> String -> [String] -> [String] -resolveShMacro st@(_,(_,_,cs,_)) c args = case lookup c cs of - Just def -> map subst def - _ -> [] ---- - where - subst s = case s of - "#1" -> unwords args - _ -> s - --- so far only one arg allowed - how to determine arg boundaries? -{- - subst s = case s of - '#':d@(_:_) | all isDigit d -> - let i = read d in if i > lg then s else args !! (i-1) -- #1 is first - _ -> s - lg = length args --} - -lookupShTerm :: HState -> String -> Maybe Tree -lookupShTerm st@(_,(_,_,_,ts)) c = lookup c ts - -txtHelpMacros :: HState -> String -txtHelpMacros (_,(_,_,cs,ts)) = unlines $ - ["Defined commands:",""] ++ - [c +++ "=" +++ unwords def | (c,def) <- cs] ++ - ["","Defined terms:",""] ++ - [c +++ "=" +++ prt_ def | (c,def) <- ts] - --- | empty command if index over -earlierCommandH :: HState -> Int -> String -earlierCommandH (_,(h,_,_,_)) = ((h ++ repeat "") !!) - -execLinesH :: String -> [CommandLine] -> HState -> IO HState -execLinesH s cs hst@(st, (h,_,_,_)) = do - (_,st') <- execLinesI True cs hst - cpu <- prOptCPU (optsHState st') (cpuHState hst) - return $ putHStateCPU cpu $ updateHistory s st' - --- | Like 'execLines', but can be interrupted by SIGINT. -execLinesI :: Bool -> [CommandLine] -> HState -> IO ([String],HState) -execLinesI put cs st = - do - x <- runInterruptibly (execLines put cs st) - case x of - Left ex -> do hPutStrLn stderr "" - hPutStrLn stderr $ show ex - return ([],st) - Right y -> return y - -ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options) -ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls] - --- | the main function: execution of commands. 'put :: Bool' forces immediate output --- --- command line with consecutive (;) commands: no value transmitted -execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState) -execLines put cs st = foldM (flip (execLine put)) ([],st) cs - --- | command line with piped (|) commands: no value returned -execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState) -execLine put (c@(co, os), arg, cs) (outps,st) = do - (st',val) <- execC c (st, arg) - let tr = oElem doTrace os || null cs -- option -tr leaves trace in pipe - make = oElem (iOpt "make") os - isErr = case arg of - AError _ -> True - _ -> False - utf = if (oElem useUTF8 os) then encodeUTF8 else id - outp = if tr then [utf (prCommandArg val)] else [] - if put then mapM_ putStrLnFlush outp else return () - if make && isErr - then exitFailure - else execs cs val (if put then [] else outps ++ outp, st') - where - execs [] arg st = return st - execs (c:cs) arg st = execLine put (c, arg, cs) st - --- | individual commands possibly piped: value returned; this is not a state monad -execC :: CommandOpt -> ShellIO -execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case comm of - - CImport file | takeExtensions file == ".gfwl" -> do - fs <- mkWordlist file - foldM (\x y -> execC (CImport y, opts) x) sa fs - - CImport file | oElem fromExamples opts -> do - es <- liftM nub $ getGFEFiles opts file - system $ "gf -examples" +++ unlines es - execC (comm, removeOption fromExamples opts) sa - CImport file -> useIOE sa $ do - st1 <- shellStateFromFiles opts st file - ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a)) - - CEmptyState -> changeState reinitShellState sa - CChangeMain ma -> changeStateErr (changeMain ma) sa - CStripState -> changeState purgeShellState sa - - CRemoveLanguage lan -> changeState (removeLang lan) sa -{- - CTransformGrammar file -> do - s <- transformGrammarFile opts file - returnArg (AString s) sa - CConvertLatex file -> do - s <- readFileIf file - returnArg (AString (convertGFTex s)) sa --} - CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa - -- good to have here for piping; eh and ec must be done on outer level - - CDefineCommand c args -> return (addShMacro (c,args) sh, AUnit) - CDefineTerm c -> do - let - a' = case a of - ASTrm _ -> s2t a - AString _ -> s2t a - _ -> a - case a' of - ATrms [trm] -> return (addShTerm (c,trm) sh, AUnit) - _ -> returnArg (AError "illegal term definition") sa - - CLinearize [] - | oElem showMulti opts -> - - changeArg (opTS2CommandArg ( - unlines . - (\t -> [optLinearizeTreeVal opts gr t | gr <- allStateGrammars st])) . s2t) sa - - | otherwise -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa ----- CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa - - CParse ----- | oElem showMulti opts -> do - | oElem (iOpt "overload") opts -> do - p <- parse $ prCommandArg a - changeArg (opTTs2CommandArg getOverloadResults) p - | oElem byLines opts -> do - let ss = (if oElem showAll opts then id else filter (not . null)) $ - lines $ prCommandArg a - mts <- mapM parse ss - let mark s ts = case ts of - [] -> [MMacros.uTree] -- to leave a trace of unparsed line - _ -> ts - let a' = ATrms [t | (s,(_,ATrms ts)) <- zip ss mts, t <- mark s ts] - changeArg (const a') sa - | otherwise -> parse $ prCommandArg a - where - parse x = do - warnDiscont opts - let p = optParseArgErrMsg opts gro x - case p of - Ok (ts,msg) - | oElem (iOpt "fail") opts && null ts -> do - putStrLnFlush ("#FAIL:" +++ x) >> changeArg (const $ ATrms ts) sa - | oElem (iOpt "ambiguous") opts && length ts > 1 -> do - putStrLnFlush ("#AMBIGUOUS:" +++ x) >> changeArg (const $ ATrms ts) sa - | oElem (iOpt "prob") opts -> do - let probs = stateProbs gro - let tps = rankByScore [(t,computeProbTree probs t) | t <- ts] - putStrLnFlush msg - mapM_ putStrLnFlush [show p | (t,p) <- tps] - changeArg (const $ ATrms (map fst tps)) sa - | otherwise -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa - Bad msg -> changeArg (const $ AError (msg +++ "input" +++ x)) sa - - CTranslate il ol -> do - let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a - returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa - - CGenerateRandom | oElem showCF opts || oElem (iOpt "prob") opts -> do - let probs = stateProbs gro - let cat = firstAbsCat opts gro - let n = optIntOrN opts flagNumber 1 - gen <- newStdGen - let ts = take n $ generateRandomTreesProb opts gen cgr probs cat - returnArg (ATrms (map (term2tree gro) ts)) sa - - CGenerateRandom -> do - let - a' = case a of - ASTrm _ -> s2t a - AString _ -> s2t a - _ -> a - case a' of - ATrms (trm:_) -> case tree2exp trm of - G.EInt _ -> do - putStrLn "Warning: Number argument deprecated, use gr -number=n instead" - ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1) - returnArg (ATrms ts) sa - _ -> do - g <- newStdGen - case (goFirstMeta (tree2loc trm) >>= refineRandom g 41 cgr) of - Ok trm' -> returnArg (ATrms [loc2tree trm']) sa - Bad s -> returnArg (AError s) sa - _ -> do - ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1) - returnArg (ATrms ts) sa - - CGenerateTrees | oElem showAll opts -> do - let - cat = firstAbsCat opts gro - outp - | oElem (iOpt "lin") opts = optLinearizeTreeVal opts gro . term2tree gro - | otherwise = prt_ - justOutput opts (generateAll opts (putStrLn . outp) cgr cat) sa - CGenerateTrees -> do - let - a' = case a of - ASTrm _ -> s2t a - AString _ -> s2t a - _ -> a - mt = case a' of - ATrms (tr:_) -> Just tr - _ -> Nothing - returnArg (ATrms $ generateTrees opts gro mt) sa - - CTreeBank | oElem doCompute opts -> do -- -c - let bank = prCommandArg a - returnArg (AString $ unlines $ testMultiTreebank opts st bank) sa - CTreeBank | oElem getTrees opts -> do -- -trees - let bank = prCommandArg a - tes = map (string2treeErr gro) $ treesTreebank opts bank - terms = [t | Ok t <- tes] - returnArg (ATrms terms) sa - CTreeBank -> do - let ts = strees $ s2t $ snd sa - comm = "command" ---- - returnArg (AString $ unlines $ mkMultiTreebank opts st comm ts) sa - - CLookupTreebank -> do - let tbs = treebanks st - let s = prCommandArg a - if null tbs - then returnArg (AError "no treebank") sa - else do - let tbi = maybe (fst $ head tbs) I.identC (getOptVal opts (aOpt "treebank")) - case lookup tbi tbs of - Nothing -> returnArg (AError ("no treebank" +++ prt tbi)) sa - Just tb -> case () of - _ | oElem (iOpt "strings") opts -> do - returnArg (AString $ unlines $ map fst $ assocsTreebank tb) sa - _ | oElem (iOpt "raw") opts -> do - returnArg (AString $ unlines $ lookupTreebank tb s) sa - _ | oElem (iOpt "assocs") opts -> do - returnArg (AString $ unlines $ map printAssoc $ assocsTreebank tb) sa - _ | oElem (iOpt "trees") opts -> do - returnArg (ATrms $ str2trees $ concatMap snd $ assocsTreebank tb) sa - _ -> do - let tes = map (string2treeErr gro) $ lookupTreebank tb s - terms = [t | Ok t <- tes] - returnArg (ATrms terms) sa - - CShowTreeGraph | oElem emitCode opts -> do -- -o - returnArg (AString $ visualizeTrees opts $ strees $ s2t a) sa - CShowTreeGraph -> do - let gv = if oElem (iOpt "mac") opts then "open" else "gv" ---- config! - let g0 = writeFile "grphtmp.dot" $ visualizeTrees opts $ strees $ s2t a - g1 = system "dot -Tps grphtmp.dot >grphtmp.ps" - g2 = system (gv +++ "grphtmp.ps &") - g3 = return () ---- system "rm -f grphtmp.*" - justOutput opts (g0 >> g1 >> g2 >> g3 >> return ()) sa - - CPutTerm -> changeArg (opTT2CommandArg (return . optTermCommand opts gro) . s2t) sa - - CWrapTerm f -> changeArg (opTT2CommandArg (return . return . wrapByFun opts gro f) . s2t) sa - CApplyTransfer f -> changeArg (opTT2CommandArg (applyTransfer opts gro transfs f) . s2t) sa - CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa - CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa - - CComputeConcrete t -> do - let prin = if (oElem (iOpt "table") opts) then printParadigm else prt - m <- return $ - maybe (I.identC "?") id $ -- meaningful if no opers in t - maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res - getOptVal opts useResource -- flag -res=m - returnArg (AString (err id (prin . stripTerm) ( - string2srcTerm src m t >>= - Ch.justCheckLTerm src >>= - Co.computeConcrete src))) sa ---- Co.computeConcreteRec src)) sa - CShowOpers t -> do - m <- return $ - maybe (I.identC "?") id $ -- meaningful if no opers in t - maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res - getOptVal opts useResource -- flag -res=m - justOutput opts (putStrLn (err id (unlines . map prOperSignature) ( - string2srcTerm src m t >>= (\t' -> - Co.computeConcrete src t' >>= (\v -> - return (L.opersForType src t' v)))))) sa - - - CTranslationQuiz il ol -> do - warnDiscont opts - justOutput opts (teachTranslation opts (sgr il) (sgr ol)) sa - CTranslationList il ol -> do - warnDiscont opts - let n = optIntOrN opts flagNumber 10 - qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n) - let hdr = unlines ["# From: " ++ prIdent il, - "# To: " ++ prIdent ol] - returnArg (AString $ hdr ++++ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa - - CMorphoQuiz -> do - warnDiscont opts - justOutput opts (teachMorpho opts gro) sa - CMorphoList -> do - let n = optIntOrN opts flagNumber 10 - warnDiscont opts - qs <- useIOE [] $ morphoTrainList opts gro (toInteger n) - returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa - - CReadFile file -> returnArgIO (readFileIf file >>= return . AString) sa - CWriteFile file -> justOutputArg opts (writeFile file) sa - CAppendFile file -> justOutputArg opts (appendFile file) sa - CSpeakAloud -> justOutputArg opts (speechGenerate opts) sa - CSpeechInput -> returnArgIO (speechInput opts gro >>= return . AString . unlines) sa - CSystemCommand s -> case a of - AUnit -> justOutput opts (system s >> return ()) sa - _ -> systemArg opts a s sa - CPutString -> changeArg (opSS2CommandArg (optStringCommand opts gro)) sa ------ CShowTerm -> changeArg (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa - CGrep ms -> changeArg (AString . unlines . filter (grep ms) . lines . prCommandArg) sa - - - CSetFlag -> changeState (addGlobalOptions opts0) sa ----- deprec! CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa - - CHelp (Just c) -> returnArg (AString (txtHelpCommand c)) sa - CHelp _ -> case opts0 of - Opts [o] | o == showAll -> returnArg (AString txtHelpFile) sa - Opts [o] | o == showDefs -> returnArg (AString (txtHelpMacros sh)) sa - Opts [o] -> returnArg (AString (txtHelpCommand ('-':prOpt o))) sa - _ -> returnArg (AString txtHelpFileSummary) sa - - CPrintGrammar -> returnArg (AString (optPrintGrammar opts gro)) sa - CPrintGlobalOptions -> justOutput opts (putStrLn $ prShellStateInfo st) sa - CPrintInformation c -> justOutput opts (useIOE () $ showInformation opts st c) sa - CPrintLanguages -> justOutput opts - (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa - CPrintMultiGrammar -> do - let cgr' = canModules $ purgeShellState st - returnArg (AString (optPrintMultiGrammar opts cgr')) sa - CShowGrammarGraph -> do - ---- sa' <- changeState purgeShellState sa - let gv = if oElem (iOpt "mac") opts then "open" else "gv" ---- config! - let g0 = writeFile "grphtmp.dot" $ visualizeCanonGrammar opts cgr - g1 = system "dot -Tps grphtmp.dot >grphtmp.ps" - g2 = system (gv +++ "grphtmp.ps &") - g3 = return () ---- system "rm -f grphtmp.*" - justOutput opts (g0 >> g1 >> g2 >> g3 >> return ()) sa - CPrintSourceGrammar -> - returnArg (AString (visualizeSourceGrammar src)) sa - ----- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa ----- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa ----- CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa - _ -> justOutput opts (putStrLn "command not understood") sa - - where - sgr = stateGrammarOfLang st - gro = grammarOfOptState opts st - opts = addOptions opts0 (globalOptions st) - src = srcModules st - cgr = canModules st - - transfs = transfers st - - s2t a = case a of - ASTrm ('$':c) -> maybe (AError "undefined term") (ATrms . return) $ lookupShTerm sh c - ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s - AString s -> err AError (ATrms . return) $ string2treeErr gro s - _ -> a - - str2trees ts = [t | Ok t <- map (string2treeErr gro) ts] - - strees a = case a of - ATrms ts -> ts - _ -> [] - - warnDiscont os = err putStrLn id $ do - let c0 = firstAbsCat os gro - c <- GrammarToCanon.redQIdent c0 - lang <- maybeErr "no concrete" $ languageOfOptState os st - t <- return $ errVal CMacros.defLinType $ Look.lookupLincat cgr $ CMacros.redirectIdent lang c - return $ if CMacros.isDiscontinuousCType t - then (putStrLn ("Warning: discontinuous category" +++ prt_ c)) - else (return ()) - - grep ms s = (if oElem invertGrep opts then not else id) $ grepv ms s --- -v - grepv ms s = case s of - _:cs -> isPrefixOf ms s || grepv ms cs - _ -> isPrefixOf ms s - --- commands either change the state or process the argument, but not both --- some commands just do output - -changeState :: ShellStateOper -> ShellIO -changeState f ((st,h),a) = return ((f st,h), a) - -changeStateErr :: ShellStateOperErr -> ShellIO -changeStateErr f ((st,h),a) = case f st of - Ok st' -> return ((st',h), a) - Bad s -> return ((st, h),AError s) - -changeArg :: (CommandArg -> CommandArg) -> ShellIO -changeArg f (st,a) = return (st, f a) - -changeArgMsg :: (CommandArg -> (CommandArg,String)) -> ShellIO -changeArgMsg f (st,a) = do - let (b,msg) = f a - putStrLnFlush msg - return (st, b) - -returnArg :: CommandArg -> ShellIO -returnArg = changeArg . const - -returnArgIO :: IO CommandArg -> ShellIO -returnArgIO io (st,_) = io >>= (\a -> return (st,a)) - -justOutputArg :: Options -> (String -> IO ()) -> ShellIO -justOutputArg opts f sa@(st,a) = f (utf (prCommandArg a)) >> return (st, AUnit) - where - utf = if (oElem useUTF8 opts) then encodeUTF8 else id - -justOutput :: Options -> IO () -> ShellIO -justOutput opts = justOutputArg opts . const - -systemArg :: Options -> CommandArg -> String -> ShellIO -systemArg _ cont syst sa = do - writeFile tmpi $ prCommandArg cont - system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo - s <- readFile tmpo - returnArg (AString s) sa - where - tmpi = "_tmpi" --- - tmpo = "_tmpo" - --- | type system for command arguments; instead of plain strings... -data CommandArg = - AError String - | ATrms [Tree] - | ASTrm String -- ^ to receive from parser - | AStrs [Str] - | AString String - | AUnit - deriving (Eq, Show) - -prCommandArg :: CommandArg -> String -prCommandArg arg = case arg of - AError s -> s - AStrs ss -> sstrV ss - AString s -> s - ATrms [] -> "no tree found" - ATrms tt -> unlines $ map prt_Tree tt - ASTrm s -> s - AUnit -> "" - -opSS2CommandArg :: (String -> String) -> CommandArg -> CommandArg -opSS2CommandArg f = AString . f . prCommandArg - -opST2CommandArg :: (String -> Err [Tree]) -> CommandArg -> CommandArg -opST2CommandArg f = err AError ATrms . f . prCommandArg - -opTS2CommandArg :: (Tree -> String) -> CommandArg -> CommandArg -opTS2CommandArg f (ATrms ts) = AString $ unlines $ map f ts -opTS2CommandArg _ (AError s) = AError ("expected term, but got error:" ++++ s) -opTS2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a) - -opTT2CommandArg :: (Tree -> Err [Tree]) -> CommandArg -> CommandArg -opTT2CommandArg f (ATrms ts) = err AError (ATrms . concat) $ mapM f ts -opTT2CommandArg _ (AError s) = AError ("expected term, but got error:" ++++ s) -opTT2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a) - -opTTs2CommandArg :: ([Tree] -> [Tree]) -> CommandArg -> CommandArg -opTTs2CommandArg f (ATrms ts) = ATrms $ f ts -opTTs2CommandArg _ (AError s) = AError ("expected terms, but got error:" ++++ s) -opTTs2CommandArg _ a = AError ("expected terms, but got:" ++++ prCommandArg a) - diff --git a/src-3.0/GF/Shell/CommandL.hs b/src-3.0/GF/Shell/CommandL.hs deleted file mode 100644 index efb6460b4..000000000 --- a/src-3.0/GF/Shell/CommandL.hs +++ /dev/null @@ -1,198 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CommandL --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/17 15:13:55 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.21 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Shell.CommandL where - -import GF.Data.Operations -import GF.Infra.UseIO - -import GF.Canon.CMacros -import GF.Grammar.Values (Tree) - -import GF.UseGrammar.GetTree -import GF.Compile.ShellState -import GF.Infra.Option -import GF.UseGrammar.Session -import GF.Shell.Commands -import GF.UseGrammar.Tokenize (wordsLits) - -import Data.Char -import Data.List (intersperse) -import Control.Monad (foldM) - -import GF.Text.UTF8 - --- | a line-based shell -initEditLoop :: CEnv -> IO () -> IO () -initEditLoop env resume = do - let env' = startEditEnv env - putStrLnFlush $ initEditMsg env' - let state = initSStateEnv env' - putStrLnFlush $ showCurrentState env' state - editLoop env' state resume - -editLoop :: CEnv -> SState -> IO () -> IO () -editLoop env state resume = do - putStrFlush "edit> " - c <- getCommand - if (isQuit c) then resume else do - (env',state') <- execCommand env c state - let package = case c of - CCEnvEmptyAndImport _ -> initEditMsgEmpty env' - _ -> showCurrentState env' state' - putStrLnFlush package - - editLoop env' state' resume - --- | execute a command script and return a tree -execCommandHistory :: CEnv -> String -> IO (CEnv,Tree) -execCommandHistory env s = do - let env' = startEditEnv env - let state = initSStateEnv env' - (env',state') <- foldM exec (env,state) $ lines s - return $ (env',treeSState state') - - where - - exec (env,state) l = do - let c = pCommand l - execCommand env c state - - - -getCommand :: IO Command -getCommand = do - s <- getLine - return $ pCommand s - --- | decodes UTF8 if u==True, i.e. if the grammar uses UTF8; --- used in the Java GUI, which always uses UTF8 -getCommandUTF :: Bool -> IO [(String,Command)] -getCommandUTF u = do - s <- getLine - return $ pCommandMsgs $ if u then decodeUTF8 s else s - -pCommandMsgs :: String -> [(String,Command)] -pCommandMsgs = map (pCommandMsg . unwords) . concatMap (chunks ";;" . words) . lines - -pCommand :: String -> Command -pCommand = snd . pCommandMsg - - -pCommandMsg :: String -> (String,Command) -pCommandMsg s = (m,pCommandWords $ words c) where - (m,c) = case s of - '[':s2 -> let (a,b) = span (/=']') s2 in (a,drop 1 b) - _ -> ("",s) - pCommandWords s = case s of - "n" : cat : _ -> CNewCat cat - "t" : ws -> CNewTree $ unwords ws - "g" : ws -> CRefineWithTree $ unwords ws -- example: *g*ive - "p" : ws -> CRefineParse $ unwords ws - "rc": i : _ -> CRefineWithClip (readIntArg i) - ">" : i : _ -> CAhead $ readIntArg i - ">" : [] -> CAhead 1 - "<" : i : _ -> CBack $ readIntArg i - "<" : [] -> CBack 1 - ">>" : _ -> CNextMeta - "<<" : _ -> CPrevMeta - "'" : _ -> CTop - "+" : _ -> CLast - "mp" : p -> CMovePosition (readIntList (unwords p)) - "ct" : p:q:_ -> CCopyPosition (readIntList p) (readIntList q) - "r" : f : _ -> CRefineWithAtom f - "w" : f:i : _ -> CWrapWithFun (f, readIntArg i) - "ch": f : _ -> CChangeHead f - "ph": f:i : _ -> CPeelHead (f, readIntArg i) - "x" : ws -> CAlphaConvert $ unwords ws - "s" : i : _ -> CSelectCand (readIntArg i) - "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm - "f" : "structured" : _ -> CAddOption showStruct --- hmmm - "f" : s : _ -> CAddOption (filterString s) - "u" : i : _ -> CUndo (readIntArg i) - "u" : _ -> CUndo 1 - "d" : _ -> CDelete - "ac" : _ -> CAddClip - "pc": i : _ -> CRemoveClip (readIntArg i) - "c" : s : _ -> CTermCommand s - "a" : _ -> CRefineRandom --- *a*leatoire - "m" : _ -> CMenu - "ml" : s : _ -> changeMenuLanguage s - "ms" : s : _ -> changeMenuSize s - "mt" : s : _ -> changeMenuTyped s - "v" : _ -> CView - "q" : _ -> CQuit - "h" : _ -> CHelp initEditMsg - - "i" : file: _ -> CCEnvImport file - "e" : [] -> CCEnvEmpty - "e" : file: _ -> CCEnvEmptyAndImport file - - "open" : f: _ -> CCEnvOpenTerm f - "openstring": f: _ -> CCEnvOpenString f - - "on" :lang: _ -> CCEnvOn lang - "off":lang: _ -> CCEnvOff lang - "pfile" :f:_ -> CCEnvRefineParse f - "tfile" :f:_ -> CCEnvRefineWithTree f - "save":l:f:_ -> CCEnvSave l f - --- openstring file --- pfile file --- tfile file --- on lang --- off lang - - "gf": comm -> CCEnvGFShell (unwords comm) - - [] -> CVoid - _ -> CError - --- | well, this lists the commands of the line-based editor -initEditMsg :: CEnv -> String -initEditMsg env = unlines $ - "State-dependent editing commands are given in the menu:" : - " n [Cat] = new, r [Fun] = refine, w [Fun] [Int] = wrap,": - " ch [Fun] = change head, d = delete, s [Int] = select," : - " x [Var] [Var] = alpha convert." : - "Commands changing the environment:" : - " i [file] = import, e = empty." : - "Other commands:" : - " a = random, v = change view, u = undo, h = help, q = quit," : - " ml [Lang] = change menu language," : - " ms (short | long) = change menu command size," : - " mt (typed | untyped) = change menu item typing," : - " p [string] = refine by parsing, g [term] = refine by term," : - " > = down, < = up, ' = top, >> = next meta, << = previous meta." : ----- (" c [" ++ unwords (intersperse "|" allTermCommands) ++ "] = modify term") : ----- (" f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") : - [] - -initEditMsgEmpty :: CEnv -> String -initEditMsgEmpty env = initEditMsg env +++++ unlines ( - "Start editing by n Cat selecting category\n\n" : - "-------------\n" : - ["n" +++ cat | (_,cat) <- newCatMenu env] - ) - -showCurrentState :: CEnv -> SState -> String -showCurrentState env' state' = - unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) - where (tr,msg,menu) = displaySStateIn env' state' - --- | to read position; borrowed from Prelude; should be elsewhere -readIntList :: String -> [Int] -readIntList s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> x - _ -> [] diff --git a/src-3.0/GF/Shell/Commands.hs b/src-3.0/GF/Shell/Commands.hs deleted file mode 100644 index 8699c2fe7..000000000 --- a/src-3.0/GF/Shell/Commands.hs +++ /dev/null @@ -1,568 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Commands --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/06 10:02:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.42 $ --- --- temporary hacks for GF 2.0 --- --- Abstract command language for syntax editing. AR 22\/8\/2001. --- Most arguments are strings, to make it easier to receive them from e.g. Java. --- See "CommandsL" for a parser of a command language. ------------------------------------------------------------------------------ - -module GF.Shell.Commands where - -import GF.Data.Operations -import GF.Data.Zipper - -import qualified GF.Grammar.Grammar as G ---- Cat, Fun, Q, QC -import GF.Canon.GFC -import GF.Canon.CMacros -import GF.Grammar.Macros (qq)---- -import GF.Grammar.LookAbs -import GF.Canon.Look -import GF.Grammar.Values (loc2treeFocus,tree2exp)---- - -import GF.UseGrammar.GetTree -import GF.API -import GF.Compile.ShellState - -import qualified GF.Shell as Shell -import qualified GF.Shell.PShell as PShell -import qualified GF.Grammar.Macros as M -import GF.Grammar.PrGrammar -import GF.Compile.PGrammar -import GF.API.IOGrammar -import GF.Infra.UseIO -import GF.Text.Unicode - -import GF.CF.CF -import GF.CF.CFIdent (cat2CFCat, cfCat2Cat) -import GF.CF.PPrCF (prCFCat) -import GF.UseGrammar.Linear -import GF.UseGrammar.Randomized -import GF.UseGrammar.Editing -import GF.UseGrammar.Session -import GF.UseGrammar.Custom - -import qualified GF.Infra.Ident as I -import GF.Infra.Option -import GF.Data.Str (sstr) ---- -import GF.Text.UTF8 ---- - -import System.Random (StdGen, mkStdGen, newStdGen) -import Control.Monad (liftM2, foldM) -import Data.List (intersperse) - ---- temporary hacks for GF 2.0 - --- Abstract command language for syntax editing. AR 22/8/2001 --- Most arguments are strings, to make it easier to receive them from e.g. Java. --- See CommandsL for a parser of a command language. - -data Command = - CNewCat String - | CNewTree String - | CAhead Int - | CBack Int - | CNextMeta - | CPrevMeta - | CTop - | CLast - | CMovePosition [Int] - | CCopyPosition [Int] [Int] - | CRefineWithTree String - | CRefineWithClip Int - | CRefineWithAtom String - | CRefineParse String - | CWrapWithFun (String,Int) - | CChangeHead String - | CPeelHead (String,Int) - | CAlphaConvert String - | CRefineRandom - | CSelectCand Int - | CTermCommand String - | CAddOption Option - | CRemoveOption Option - | CDelete - | CAddClip - | CRemoveClip Int - | CUndo Int - | CView - | CMenu - | CQuit - | CHelp (CEnv -> String) -- ^ help message depends on grammar and interface - | CError -- ^ syntax error in command - | CVoid -- ^ empty command, e.g. just \ - - | CCEnvImport String -- ^ |-- commands affecting 'CEnv' - | CCEnvEmptyAndImport String -- ^ | - | CCEnvOpenTerm String -- ^ | - | CCEnvOpenString String -- ^ | - | CCEnvEmpty -- ^ | - - | CCEnvOn String -- ^ | - | CCEnvOff String -- ^ | - - | CCEnvGFShell String -- ^ |========== - - | CCEnvRefineWithTree String -- ^ |-- other commands using 'IO' - | CCEnvRefineParse String -- ^ | - | CCEnvSave String FilePath -- ^ |========== - -isQuit :: Command -> Bool -isQuit CQuit = True -isQuit _ = False - --- | an abstract environment type -type CEnv = ShellState - -grammarCEnv :: CEnv -> StateGrammar -grammarCEnv = firstStateGrammar - -canCEnv :: CEnv -> CanonGrammar -canCEnv = canModules - -concreteCEnv, abstractCEnv :: StateGrammar -> I.Ident -concreteCEnv = cncId -abstractCEnv = absId - -stdGenCEnv :: CEnv -> SState -> StdGen -stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- - -initSStateEnv :: CEnv -> SState -initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of - Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState - _ -> initSState - where - sgr = firstStateGrammar env - abs = absId sgr - gr = stateGrammarST sgr - --- | the main function -execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState) -execCommand env c s = case c of - --- these commands do need IO - CCEnvImport file -> useIOE (env,s) $ do - st <- shellStateFromFiles optss env file - return (st,s) - - CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do - st <- shellStateFromFiles optss emptyShellState file - return (startEditEnv st,initSState) - - CCEnvEmpty -> do - return (startEditEnv emptyShellState, initSState) - - CCEnvGFShell command -> do - let hs = Shell.initHState env - let cs = PShell.pCommandLines hs command - (msg,(env',_)) <- Shell.execLines False cs hs - return (env', changeMsg msg s) ---- - - CCEnvOpenTerm file -> do - c <- readFileIf file - let (fs,t) = envAndTerm file c ----- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec ----- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs - let env' = env ---- - return (env', execECommand env' (CNewTree t) s) - - CCEnvOpenString file -> do - c <- readFileIf file - let (fs,t) = envAndTerm file c ----- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec ----- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs - let env' = env ---- - return (env', execECommand env' (CRefineParse t) s) - - CCEnvOn name -> return (languageOn (language name) env,s) - CCEnvOff name -> return (languageOff (language name) env,s) - - CCEnvSave lang file -> do - let str = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) $ treeSState s - writeFile file str - let msg = ["wrote file" +++ file] - return (env,changeMsg msg s) - --- this command is improved by the use of IO - CRefineRandom -> do - g <- newStdGen - return (env, action2commandNext (refineRandom g 41 cgr) s) - --- these commands use IO - CCEnvRefineWithTree file -> do - str <- readFileIf file - execCommand env (CRefineWithTree str) s - CCEnvRefineParse file -> do - str <- readFileIf file - execCommand env (CRefineParse str) s - --- other commands don't need IO; they are available in the fudget - c -> return (env, execECommand env c s) - - where - gr = grammarCEnv env - cgr = canCEnv env - opts = globalOptions env - optss = addOption beSilent opts - - -- format for documents: - -- GF commands of form "-- command", then term or text - envAndTerm f s = - (unwords (intersperse ";;" fs), unlines ss) where - (fs,ss) = span isImport (lines s) - isImport l = take 2 l == "--" - - -execECommand :: CEnv -> Command -> ECommand -execECommand env c = case c of - CNewCat cat -> action2commandNext $ \x -> do - cat' <- string2cat sgr cat - s' <- newCat cgr cat' x - uniqueRefinements cgr s' - CNewTree s -> action2commandNext $ \x -> do - t <- string2treeErr gr s - s' <- newTree t x - uniqueRefinements cgr s' - CAhead n -> action2command (goAheadN n) - CBack n -> action2command (goBackN n) - CTop -> action2command $ return . goRoot - CLast -> action2command $ goLast - CMovePosition p -> action2command $ goPosition p - CNextMeta -> action2command goNextNewMeta - CPrevMeta -> action2command goPrevNewMeta - CRefineWithAtom s -> action2commandNext $ \x -> do - t <- string2ref gr s - s' <- refineWithAtom der cgr t x - uniqueRefinements cgr s' - CWrapWithFun (f,i) -> action2commandKeep $ wrapWithFun cgr (qualif f, i) - CChangeHead f -> action2commandKeep $ changeFunHead cgr (qualif f) - CPeelHead (f,i) -> action2commandKeep $ peelFunHead cgr (qualif f,i) - - CAlphaConvert s -> action2commandKeep $ \x -> - string2varPair s >>= \xy -> alphaConvert cgr xy x - - CRefineWithTree s -> action2commandNext $ \x -> - (string2treeInState gr s x >>= - \t -> refineWithTree der cgr t x) - CRefineWithClip i -> \s -> - let et = getNumberedClip i s - in (case et of - Ok t -> refineByTrees der cgr [t] s - Bad m -> changeMsg [m] s) - CCopyPosition p q -> action2command $ \s -> do - s1 <- goPosition p s - let t = actTree s1 - s2 <- goPosition q s1 - let compat = actVal s1 == actVal s2 - if compat - then refineWithTree der cgr t s2 - else return s - - CRefineParse str -> \s -> - let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s))) - ts = parseAny agrs cat str - in (if null ts ---- debug - then withMsg ["parse failed in cat" +++ prCFCat cat] - else id) - (refineByTrees der cgr ts) s - - CRefineRandom -> \s -> action2commandNext - (refineRandom (stdGenCEnv env s) 41 cgr) s - - CSelectCand i -> selectCand cgr i - - CTermCommand c -> case c of - "reindex" -> \s -> - replaceByTermCommand der gr c (actTree (stateSState s)) s - "paraphrase" -> \s -> - replaceByTermCommand der gr c (actTree (stateSState s)) s ----- "transfer" -> action2commandNext $ ----- transferSubTree (stateTransferFun sgr) gr - "generate" -> \s -> - replaceByTermCommand der gr c (actTree (stateSState s)) s - _ -> replaceByEditCommand gr c - - CAddOption o -> changeStOptions (addOption o) - CRemoveOption o -> changeStOptions (removeOption o) - CDelete -> action2commandKeep $ deleteSubTree cgr - CAddClip -> \s -> (addtoClip (actTree (stateSState s))) s - CRemoveClip n -> \s -> (removeClip n) s - CUndo n -> undoCommand n - CMenu -> \s -> changeMsg (menuState env s) s - CView -> changeView - CHelp h -> changeMsg [h env] - CVoid -> id - _ -> changeMsg ["command not yet implemented"] - where - sgr = firstStateGrammar env - agrs = allActiveGrammars env - cgr = canCEnv env - gr = grammarCEnv env - der = maybe True not $ caseYesNo (globalOptions env) noDepTypes - -- if there are dep types, then derived refs; deptypes is the default - abs = absId sgr - qualif = string2Fun gr - --- - - -string2varPair :: String -> Err (I.Ident,I.Ident) -string2varPair s = case words s of - x : y : [] -> liftM2 (,) (string2ident x) (string2ident y) - _ -> Bad "expected format 'x y'" - - -startEditEnv :: CEnv -> CEnv -startEditEnv env = addGlobalOptions (options [sizeDisplay "short"]) env - --- | seen on display -cMenuDisplay :: String -> Command -cMenuDisplay s = CAddOption (menuDisplay s) - -newCatMenu :: CEnv -> [(Command, String)] -newCatMenu env = [(CNewCat (prQIdent c), printname env initSState c) | - (c,[]) <- allCatsOf (canCEnv env)] - -mkRefineMenu :: CEnv -> SState -> [(Command,String)] -mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate] - -mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))] -mkRefineMenuAll env sstate = - case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of - ([],[],wraps) -> - [(CWrapWithFun (prQIdent_ f, i), prWrap "w" "Wrap" fit) - | fit@((f,i),_) <- wraps] ++ - [(CChangeHead (prQIdent_ f), prChangeHead f) - | f <- headChangesState cgr state] ++ - [(CPeelHead (prQIdent_ f, i), prPeel "ph" "PeelHead" fi) - | fi@(f,i) <- peelingsState cgr state] ++ - [(CDelete, (ifShort "d" "Delete", "d"))] ++ - [(CAddClip, (ifShort "ac" "AddClip", "ac"))] - (refs,[],_) -> - [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] ++ - [(CRefineWithClip i, prClip i t) | (i,t) <- possClipsSState gr sstate] - (_,cands,_) -> - [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] - - where - prRef (f,(t,_)) = - (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt_ t), - "r" +++ prRefinement f) - prClip i t = - (ifShort "rc" "Paste" +++ prOrLinTree t, - "rc" +++ show i) - prChangeHead f = - (ifShort "ch" "ChangeHead" +++ prOrLinFun f, - "ch" +++ prQIdent_ f) - prWrap sh lg ((f,i),t) = - (ifShort sh lg +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ - ifShort (show i) (prBracket (show i)), - sh +++ prQIdent_ f +++ show i) - prPeel sh lg (f,i) = - (ifShort sh lg +++ prOrLinFun f +++ - ifShort (show i) (prBracket (show i)), - sh +++ prQIdent_ f +++ show i) - prCand (t,i) = - (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i) - - gr = grammarCEnv env - cgr = canCEnv env - state = stateSState sstate - opts = addOptions (optsSState sstate) (globalOptions env) - ifOpt f v a b = case getOptVal opts f of - Just s | s == v -> a - _ -> b - ifShort = ifOpt sizeDisplay "short" - ifTyped t = ifOpt typeDisplay "typed" t "" - prOrLinExp t = err (const $ prt_ t) prOrLinTree $ annotateInState cgr t state - prOrLinRef t = case t of - G.Q m f -> printname env sstate (m,f) - G.QC m f -> printname env sstate (m,f) - _ -> prt_ t - prOrLinFun = printname env sstate - prOrLinTree t = case getOptVal opts menuDisplay of - Just "Abs" -> prt_ $ tree2exp t ---- prTermOpt opts $ tree2exp t - Just lang -> prQuotedString $ lin lang t - _ -> prTermOpt opts $ tree2exp t - lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t - --- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped --- the default is Abs, long, untyped; the Menus menu changes the parameter - -emptyMenuItem :: (Command, (String, String)) -emptyMenuItem = (CVoid,("","")) - - - ----- allStringCommands = snd $ customInfo customStringCommand -termCommandMenu :: [(Command,String)] -termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] - -allTermCommands :: [String] -allTermCommands = snd $ customInfo customEditCommand - -stringCommandMenu :: [(Command,String)] -stringCommandMenu = [] - -displayCommandMenu :: CEnv -> [(Command,String)] -displayCommandMenu env = - [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ - [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ - [(fo nostripQualif, s) | (fo,s) <- [(CAddOption,"qualified"), - (CRemoveOption,"unqualified")]] ++ - [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] - where - langs = map prLanguage $ allLanguages env - -{- ---- - -stringCommandMenu = - (CAddOption showStruct, "structured") : - (CRemoveOption showStruct, "unstructured") : - [(CAddOption (filterString s), s) | s <- allStringCommands] --} - -changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command -changeMenuLanguage s = CAddOption (menuDisplay s) -changeMenuSize s = CAddOption (sizeDisplay s) -changeMenuTyped s = CAddOption (typeDisplay s) - -menuState :: CEnv -> SState -> [String] -menuState env = map snd . mkRefineMenu env - -prState :: State -> [String] -prState s = prMarkedTree (loc2treeMarked s) - -displayJustStateIn :: CEnv -> SState -> String -displayJustStateIn env state = case displaySStateIn env state of - (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF - -displaySStateIn :: CEnv -> SState -> ([String],[String],[(String,String)]) -displaySStateIn env state = (tree',msg,menu) where - (tree,msg,menu) = displaySState env state - grs = allStateGrammars env - lang = (viewSState state) `mod` (length grs + 3) - tree' = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang - opts = addOptions (optsSState state) -- state opts override - (addOption (markLin markOptFocus) (globalOptions env)) - lin g = linearizeState fudWrap opts g zipper - exp = return $ tree2string $ loc2tree zipper - zipper = stateSState state - linAll = map lin grs - separ = singleton . map unlines . intersperse [replicate 72 '*'] - --- | the Boolean is a temporary hack to have two parallel GUIs -displaySStateJavaX :: Bool -> CEnv -> SState -> String -> String -displaySStateJavaX isNew env state m = encodeUTF8 $ mkUnicode $ - unlines $ tagXML "gfedit" $ concat [ - if null m then [] else tagXML "hmsg" [m], - tagXML "linearizations" (concat - [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]), - tagXML "tree" tree, - tagXML "message" msg, - tagXML "menu" (tagsXML "item" menu') - ] - where - (tree,msg,menu) = displaySState env state - menu' = [tagXML "show" [unicode s] ++ tagXML "send" [c] | (s,c) <- menu] - (ls,grs) = unzip $ lgrs - lgrs = allActiveStateGrammarsWithNames env - lins = (langAbstract, exp) : linAll - opts = addOptions (optsSState state) -- state opts override - (addOption (markLin mark) (globalOptions env)) - lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where - uni = optDecodeUTF8 gr - exp = prprTree $ loc2tree zipper - zipper = stateSState state - linAll = map lin lgrs - gr = firstStateGrammar env - mark = markOptXML -- markOptJava - - unicode = case getOptVal opts menuDisplay of - Just lang -> optDecodeUTF8 (stateGrammarOfLang env (language lang)) - _ -> id - --- | the env is UTF8 if the display language is --- --- should be independent -isCEnvUTF8 :: CEnv -> SState -> Bool -isCEnvUTF8 env st = maybe False id $ do - lang <- getOptVal opts menuDisplay - co <- getOptVal (stateOptions (stateGrammarOfLang env (language lang))) uniCoding - return $ co == "utf8" - where - opts = addOptions (optsSState st) (globalOptions env) - -langAbstract, langXML :: I.Ident -langAbstract = language "Abstract" -langXML = language "XML" - -linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] -linearizeState wrap opts gr = - wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus - - where - unt = customOrDefault (stateOptions gr) useUntokenizer customUntokenizer gr - strop = maybe id ($ gr) $ customAsOptVal opts filterString customStringCommand - br = oElem showStruct opts - -noWrap, fudWrap :: String -> [String] -noWrap = lines -fudWrap = lines . wrapLines 0 --- - -displaySState :: CEnv -> SState -> ([String],[String],[(String,String)]) -displaySState env state = - (prState (stateSState state), msgSState state, menuSState env state) - -menuSState :: CEnv -> SState -> [(String,String)] -menuSState env state = if null cs then [("[NO ALTERNATIVE]","")] else cs - where - cs = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state] - -printname :: CEnv -> SState -> G.Fun -> String -printname env state f = case getOptVal opts menuDisplay of - Just "Abs" -> prQIdent_ f - Just lang -> printn lang f - _ -> prQIdent_ f ---- prTermOpt opts (qq f) - where - opts = addOptions (optsSState state) (globalOptions env) - printn lang f = err id (ifNull (prQIdent_ f) (sstr . head)) $ do - t <- lookupPrintname gr mf - strsFromTerm t - where - sgr = stateGrammarOfLang env (language lang) - gr = grammar sgr - mf = ciq (cncId sgr) (snd f) - --- * XML printing; does not belong here! - -tagsXML :: String -> [[String]] -> [String] -tagsXML t = concatMap (tagXML t) - -tagAttrXML :: String -> (String, String) -> [String] -> [String] -tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] - -tagXML :: String -> [String] -> [String] -tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] - -mkTagXML :: String -> String -mkTagXML t = '<':t ++ ">" - -mkEndTagXML :: String -> String -mkEndTagXML t = mkTagXML ('/':t) - -mkTagAttrsXML :: String -> [(String, String)] -> String -mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" - -mkTagAttrXML :: String -> (String, String) -> String -mkTagAttrXML t av = mkTagAttrsXML t [av] - diff --git a/src-3.0/GF/Shell/HelpFile.hs b/src-3.0/GF/Shell/HelpFile.hs deleted file mode 100644 index 43fae7c42..000000000 --- a/src-3.0/GF/Shell/HelpFile.hs +++ /dev/null @@ -1,723 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Shell.HelpFile --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/12 10:03:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- Help on shell commands. Generated from HelpFile by 'make help'. --- PLEASE DON'T EDIT THIS FILE. ------------------------------------------------------------------------------ - - -module GF.Shell.HelpFile where - -import GF.Data.Operations - -txtHelpFileSummary = - unlines $ map (concat . take 1 . lines) $ paragraphs txtHelpFile - -txtHelpCommand c = - case lookup c [(takeWhile (/=',') p,p) | p <- paragraphs txtHelpFile] of - Just s -> s - _ -> "Command not found." - -txtHelpFile = - "\n-- GF help file updated for GF 2.6, 17/6/2006." ++ - "\n-- *: Commands and options marked with * are currently not implemented." ++ - "\n--" ++ - "\n-- Each command has a long and a short name, options, and zero or more" ++ - "\n-- arguments. Commands are sorted by functionality. The short name is" ++ - "\n-- given first." ++ - "\n" ++ - "\n-- Type \"h -all\" for full help file, \"h \" for full help on a command. " ++ - "\n" ++ - "\n-- commands that change the state" ++ - "\n" ++ - "\ni, import: i File" ++ - "\n Reads a grammar from File and compiles it into a GF runtime grammar." ++ - "\n Files \"include\"d in File are read recursively, nubbing repetitions." ++ - "\n If a grammar with the same language name is already in the state," ++ - "\n it is overwritten - but only if compilation succeeds. " ++ - "\n The grammar parser depends on the file name suffix:" ++ - "\n .gf normal GF source" ++ - "\n .gfc canonical GF" ++ - "\n .gfr precompiled GF resource " ++ - "\n .gfcm multilingual canonical GF" ++ - "\n .gfe example-based grammar files (only with the -ex option)" ++ - "\n .gfwl multilingual word list (preprocessed to abs + cncs)" ++ - "\n .ebnf Extended BNF format" ++ - "\n .cf Context-free (BNF) format" ++ - "\n .trc TransferCore format" ++ - "\n options:" ++ - "\n -old old: parse in GF<2.0 format (not necessary)" ++ - "\n -v verbose: give lots of messages " ++ - "\n -s silent: don't give error messages" ++ - "\n -src from source: ignore precompiled gfc and gfr files" ++ - "\n -gfc from gfc: use compiled modules whenever they exist" ++ - "\n -retain retain operations: read resource modules (needed in comm cc) " ++ - "\n -nocf don't build old-style context-free grammar (default without HOAS)" ++ - "\n -docf do build old-style context-free grammar (default with HOAS)" ++ - "\n -nocheckcirc don't eliminate circular rules from CF " ++ - "\n -cflexer build an optimized parser with separate lexer trie" ++ - "\n -noemit do not emit code (default with old grammar format)" ++ - "\n -o do emit code (default with new grammar format)" ++ - "\n -ex preprocess .gfe files if needed" ++ - "\n -prob read probabilities from top grammar file (format --# prob Fun Double)" ++ - "\n -treebank read a treebank file to memory (xml format)" ++ - "\n flags:" ++ - "\n -abs set the name used for abstract syntax (with -old option)" ++ - "\n -cnc set the name used for concrete syntax (with -old option)" ++ - "\n -res set the name used for resource (with -old option)" ++ - "\n -path use the (colon-separated) search path to find modules" ++ - "\n -optimize select an optimization to override file-defined flags" ++ - "\n -conversion select parsing method (values strict|nondet)" ++ - "\n -probs read probabilities from file (format (--# prob) Fun Double)" ++ - "\n -preproc use a preprocessor on each source file" ++ - "\n -noparse read nonparsable functions from file (format --# noparse Funs) " ++ - "\n examples:" ++ - "\n i English.gf -- ordinary import of Concrete" ++ - "\n i -retain german/ParadigmsGer.gf -- import of Resource to test" ++ - "\n" ++ - "\nr, reload: r" ++ - "\n Executes the previous import (i) command." ++ - "\n " ++ - "\nrl, remove_language: rl Language" ++ - "\n Takes away the language from the state." ++ - "\n" ++ - "\ne, empty: e" ++ - "\n Takes away all languages and resets all global flags." ++ - "\n" ++ - "\nsf, set_flags: sf Flag*" ++ - "\n The values of the Flags are set for Language. If no language" ++ - "\n is specified, the flags are set globally." ++ - "\n examples:" ++ - "\n sf -nocpu -- stop showing CPU time" ++ - "\n sf -lang=Swe -- make Swe the default concrete" ++ - "\n" ++ - "\ns, strip: s" ++ - "\n Prune the state by removing source and resource modules." ++ - "\n" ++ - "\ndc, define_command Name Anything" ++ - "\n Add a new defined command. The Name must star with '%'. Later," ++ - "\n if 'Name X' is used, it is replaced by Anything where #1 is replaced" ++ - "\n by X. " ++ - "\n Restrictions: Currently at most one argument is possible, and a defined" ++ - "\n command cannot appear in a pipe. " ++ - "\n To see what definitions are in scope, use help -defs." ++ - "\n examples:" ++ - "\n dc %tnp p -cat=NP -lang=Eng #1 | l -lang=Swe -- translate NPs" ++ - "\n %tnp \"this man\" -- translate and parse" ++ - "\n" ++ - "\ndt, define_term Name Tree" ++ - "\n Add a constant for a tree. The constant can later be called by" ++ - "\n prefixing it with '$'. " ++ - "\n Restriction: These terms are not yet usable as a subterm. " ++ - "\n To see what definitions are in scope, use help -defs." ++ - "\n examples:" ++ - "\n p -cat=NP \"this man\" | dt tm -- define tm as parse result" ++ - "\n l -all $tm -- linearize tm in all forms" ++ - "\n" ++ - "\n-- commands that give information about the state" ++ - "\n" ++ - "\npg, print_grammar: pg" ++ - "\n Prints the actual grammar (overridden by the -lang=X flag)." ++ - "\n The -printer=X flag sets the format in which the grammar is" ++ - "\n written." ++ - "\n N.B. since grammars are compiled when imported, this command" ++ - "\n generally does not show the grammar in the same format as the" ++ - "\n source. In particular, the -printer=latex is not supported. " ++ - "\n Use the command tg -printer=latex File to print the source " ++ - "\n grammar in LaTeX." ++ - "\n options:" ++ - "\n -utf8 apply UTF8-encoding to the grammar" ++ - "\n flags: " ++ - "\n -printer" ++ - "\n -lang" ++ - "\n -startcat -- The start category of the generated grammar." ++ - "\n Only supported by some grammar printers." ++ - "\n examples:" ++ - "\n pg -printer=cf -- show the context-free skeleton" ++ - "\n" ++ - "\npm, print_multigrammar: pm" ++ - "\n Prints the current multilingual grammar in .gfcm form." ++ - "\n (Automatically executes the strip command (s) before doing this.)" ++ - "\n options:" ++ - "\n -utf8 apply UTF8 encoding to the tokens in the grammar" ++ - "\n -utf8id apply UTF8 encoding to the identifiers in the grammar" ++ - "\n examples:" ++ - "\n pm | wf Letter.gfcm -- print the grammar into the file Letter.gfcm" ++ - "\n pm -printer=graph | wf D.dot -- then do 'dot -Tps D.dot > D.ps'" ++ - "\n" ++ - "\nvg, visualize_graph: vg" ++ - "\n Show the dependency graph of multilingual grammar via dot and gv." ++ - "\n" ++ - "\npo, print_options: po" ++ - "\n Print what modules there are in the state. Also" ++ - "\n prints those flag values in the current state that differ from defaults." ++ - "\n" ++ - "\npl, print_languages: pl" ++ - "\n Prints the names of currently available languages." ++ - "\n" ++ - "\npi, print_info: pi Ident" ++ - "\n Prints information on the identifier." ++ - "\n" ++ - "\n-- commands that execute and show the session history" ++ - "\n" ++ - "\neh, execute_history: eh File" ++ - "\n Executes commands in the file." ++ - "\n" ++ - "\nph, print_history; ph" ++ - "\n Prints the commands issued during the GF session." ++ - "\n The result is readable by the eh command." ++ - "\n examples:" ++ - "\n ph | wf foo.hist\" -- save the history into a file" ++ - "\n" ++ - "\n-- linearization, parsing, translation, and computation" ++ - "\n" ++ - "\nl, linearize: l PattList? Tree" ++ - "\n Shows all linearization forms of Tree by the actual grammar" ++ - "\n (which is overridden by the -lang flag). " ++ - "\n The pattern list has the form [P, ... ,Q] where P,...,Q follow GF " ++ - "\n syntax for patterns. All those forms are generated that match with the" ++ - "\n pattern list. Too short lists are filled with variables in the end." ++ - "\n Only the -table flag is available if a pattern list is specified." ++ - "\n HINT: see GF language specification for the syntax of Pattern and Term." ++ - "\n You can also copy and past parsing results." ++ - "\n options: " ++ - "\n -struct bracketed form" ++ - "\n -table show parameters (not compatible with -record, -all)" ++ - "\n -record record, i.e. explicit GF concrete syntax term (not compatible with -table, -all)" ++ - "\n -all show all forms and variants (not compatible with -record, -table)" ++ - "\n -multi linearize to all languages (can be combined with the other options)" ++ - "\n flags:" ++ - "\n -lang linearize in this grammar" ++ - "\n -number give this number of forms at most" ++ - "\n -unlexer filter output through unlexer" ++ - "\n examples:" ++ - "\n l -lang=Swe -table -- show full inflection table in Swe" ++ - "\n" ++ - "\np, parse: p String" ++ - "\n Shows all Trees returned for String by the actual" ++ - "\n grammar (overridden by the -lang flag), in the category S (overridden" ++ - "\n by the -cat flag)." ++ - "\n options for batch input:" ++ - "\n -lines parse each line of input separately, ignoring empty lines" ++ - "\n -all as -lines, but also parse empty lines" ++ - "\n -prob rank results by probability" ++ - "\n -cut stop after first lexing result leading to parser success" ++ - "\n -fail show strings whose parse fails prefixed by #FAIL" ++ - "\n -ambiguous show strings that have more than one parse prefixed by #AMBIGUOUS" ++ - "\n options for selecting parsing method:" ++ - "\n -fcfg parse using a fast variant of MCFG (default is no HOAS in grammar)" ++ - "\n -old parse using an overgenerating CFG (default if HOAS in grammar)" ++ - "\n -cfg parse using a much less overgenerating CFG" ++ - "\n -mcfg parse using an even less overgenerating MCFG" ++ - "\n Note: the first time parsing with -cfg, -mcfg, and -fcfg may take a long time" ++ - "\n options that only work for the -old default parsing method:" ++ - "\n -n non-strict: tolerates morphological errors" ++ - "\n -ign ignore unknown words when parsing" ++ - "\n -raw return context-free terms in raw form" ++ - "\n -v verbose: give more information if parsing fails" ++ - "\n flags:" ++ - "\n -cat parse in this category" ++ - "\n -lang parse in this grammar" ++ - "\n -lexer filter input through this lexer" ++ - "\n -parser use this parsing strategy" ++ - "\n -number return this many results at most" ++ - "\n examples:" ++ - "\n p -cat=S -mcfg \"jag \228r gammal\" -- parse an S with the MCFG" ++ - "\n rf examples.txt | p -lines -- parse each non-empty line of the file" ++ - "\n" ++ - "\nat, apply_transfer: at (Module.Fun | Fun)" ++ - "\n Transfer a term using Fun from Module, or the topmost transfer" ++ - "\n module. Transfer modules are given in the .trc format. They are" ++ - "\n shown by the 'po' command." ++ - "\n flags:" ++ - "\n -lang typecheck the result in this lang instead of default lang" ++ - "\n examples:" ++ - "\n p -lang=Cncdecimal \"123\" | at num2bin | l -- convert dec to bin" ++ - "\n" ++ - "\ntb, tree_bank: tb" ++ - "\n Generate a multilingual treebank from a list of trees (default) or compare" ++ - "\n to an existing treebank." ++ - "\n options:" ++ - "\n -c compare to existing xml-formatted treebank" ++ - "\n -trees return the trees of the treebank" ++ - "\n -all show all linearization alternatives (branches and variants)" ++ - "\n -table show tables of linearizations with parameters" ++ - "\n -record show linearization records" ++ - "\n -xml wrap the treebank (or comparison results) with XML tags" ++ - "\n -mem write the treebank in memory instead of a file TODO" ++ - "\n examples:" ++ - "\n gr -cat=S -number=100 | tb -xml | wf tb.xml -- random treebank into file" ++ - "\n rf tb.xml | tb -c -- compare-test treebank from file" ++ - "\n rf old.xml | tb -trees | tb -xml -- create new treebank from old" ++ - "\n" ++ - "\nut, use_treebank: ut String" ++ - "\n Lookup a string in a treebank and return the resulting trees." ++ - "\n Use 'tb' to create a treebank and 'i -treebank' to read one from" ++ - "\n a file." ++ - "\n options:" ++ - "\n -assocs show all string-trees associations in the treebank" ++ - "\n -strings show all strings in the treebank" ++ - "\n -trees show all trees in the treebank" ++ - "\n -raw return the lookup result as string, without typechecking it" ++ - "\n flags:" ++ - "\n -treebank use this treebank (instead of the latest introduced one)" ++ - "\n examples:" ++ - "\n ut \"He adds this to that\" | l -multi -- use treebank lookup as parser in translation" ++ - "\n ut -assocs | grep \"ComplV2\" -- show all associations with ComplV2" ++ - "\n" ++ - "\ntt, test_tokenizer: tt String" ++ - "\n Show the token list sent to the parser when String is parsed." ++ - "\n HINT: can be useful when debugging the parser." ++ - "\n flags: " ++ - "\n -lexer use this lexer" ++ - "\n examples:" ++ - "\n tt -lexer=codelit \"2*(x + 3)\" -- a favourite lexer for program code" ++ - "\n" ++ - "\ng, grep: g String1 String2" ++ - "\n Grep the String1 in the String2. String2 is read line by line," ++ - "\n and only those lines that contain String1 are returned." ++ - "\n flags:" ++ - "\n -v return those lines that do not contain String1." ++ - "\n examples:" ++ - "\n pg -printer=cf | grep \"mother\" -- show cf rules with word mother" ++ - "\n" ++ - "\ncc, compute_concrete: cc Term" ++ - "\n Compute a term by concrete syntax definitions. Uses the topmost" ++ - "\n resource module (the last in listing by command po) to resolve " ++ - "\n constant names. " ++ - "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ - "\n the oper definitions to be retained after compilation; otherwise this" ++ - "\n command does not expand oper constants." ++ - "\n N.B.' The resulting Term is not a term in the sense of abstract syntax," ++ - "\n and hence not a valid input to a Tree-demanding command." ++ - "\n flags:" ++ - "\n -table show output in a similar readable format as 'l -table'" ++ - "\n -res use another module than the topmost one" ++ - "\n examples:" ++ - "\n cc -res=ParadigmsFin (nLukko \"hyppy\") -- inflect \"hyppy\" with nLukko" ++ - "\n" ++ - "\nso, show_operations: so Type" ++ - "\n Show oper operations with the given value type. Uses the topmost " ++ - "\n resource module to resolve constant names. " ++ - "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ - "\n the oper definitions to be retained after compilation; otherwise this" ++ - "\n command does not find any oper constants." ++ - "\n N.B.' The value type may not be defined in a supermodule of the" ++ - "\n topmost resource. In that case, use appropriate qualified name." ++ - "\n flags:" ++ - "\n -res use another module than the topmost one" ++ - "\n examples:" ++ - "\n so -res=ParadigmsFin ResourceFin.N -- show N-paradigms in ParadigmsFin" ++ - "\n" ++ - "\nt, translate: t Lang Lang String" ++ - "\n Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++ - "\n flags:" ++ - "\n -cat" ++ - "\n -lexer" ++ - "\n -parser" ++ - "\n examples:" ++ - "\n t Eng Swe -cat=S \"every number is even or odd\"" ++ - "\n" ++ - "\ngr, generate_random: gr Tree?" ++ - "\n Generates a random Tree of a given category. If a Tree" ++ - "\n argument is given, the command completes the Tree with values to" ++ - "\n the metavariables in the tree. " ++ - "\n options:" ++ - "\n -prob use probabilities (works for nondep types only)" ++ - "\n -cf use a very fast method (works for nondep types only)" ++ - "\n flags:" ++ - "\n -cat generate in this category" ++ - "\n -lang use the abstract syntax of this grammar" ++ - "\n -number generate this number of trees (not impl. with Tree argument)" ++ - "\n -depth use this number of search steps at most" ++ - "\n examples:" ++ - "\n gr -cat=Query -- generate in category Query" ++ - "\n gr (PredVP ? (NegVG ?)) -- generate a random tree of this form" ++ - "\n gr -cat=S -tr | l -- gererate and linearize" ++ - "\n" ++ - "\ngt, generate_trees: gt Tree?" ++ - "\n Generates all trees up to a given depth. If the depth is large," ++ - "\n a small -alts is recommended. If a Tree argument is given, the" ++ - "\n command completes the Tree with values to the metavariables in" ++ - "\n the tree." ++ - "\n options:" ++ - "\n -metas also return trees that include metavariables" ++ - "\n -all generate all (can be infinitely many, lazily)" ++ - "\n -lin linearize result of -all (otherwise, use pipe to linearize)" ++ - "\n flags:" ++ - "\n -depth generate to this depth (default 3)" ++ - "\n -atoms take this number of atomic rules of each category (default unlimited)" ++ - "\n -alts take this number of alternatives at each branch (default unlimited)" ++ - "\n -cat generate in this category" ++ - "\n -nonub don't remove duplicates (faster, not effective with -mem)" ++ - "\n -mem use a memorizing algorithm (often faster, usually more memory-consuming)" ++ - "\n -lang use the abstract syntax of this grammar" ++ - "\n -number generate (at most) this number of trees (also works with -all)" ++ - "\n -noexpand don't expand these categories (comma-separated, e.g. -noexpand=V,CN)" ++ - "\n -doexpand only expand these categories (comma-separated, e.g. -doexpand=V,CN)" ++ - "\n examples:" ++ - "\n gt -depth=10 -cat=NP -- generate all NP's to depth 10 " ++ - "\n gt (PredVP ? (NegVG ?)) -- generate all trees of this form" ++ - "\n gt -cat=S -tr | l -- generate and linearize" ++ - "\n gt -noexpand=NP | l -mark=metacat -- the only NP is meta, linearized \"?0 +NP\"" ++ - "\n gt | l | p -lines -ambiguous | grep \"#AMBIGUOUS\" -- show ambiguous strings" ++ - "\n" ++ - "\nma, morphologically_analyse: ma String" ++ - "\n Runs morphological analysis on each word in String and displays" ++ - "\n the results line by line." ++ - "\n options:" ++ - "\n -short show analyses in bracketed words, instead of separate lines" ++ - "\n -status show just the work at success, prefixed with \"*\" at failure" ++ - "\n flags:" ++ - "\n -lang" ++ - "\n examples:" ++ - "\n wf Bible.txt | ma -short | wf Bible.tagged -- analyse the Bible" ++ - "\n" ++ - "\n" ++ - "\n-- elementary generation of Strings and Trees" ++ - "\n" ++ - "\nps, put_string: ps String" ++ - "\n Returns its argument String, like Unix echo." ++ - "\n HINT. The strength of ps comes from the possibility to receive the " ++ - "\n argument from a pipeline, and altering it by the -filter flag." ++ - "\n flags:" ++ - "\n -filter filter the result through this string processor " ++ - "\n -length cut the string after this number of characters" ++ - "\n examples:" ++ - "\n gr -cat=Letter | l | ps -filter=text -- random letter as text" ++ - "\n" ++ - "\npt, put_tree: pt Tree" ++ - "\n Returns its argument Tree, like a specialized Unix echo." ++ - "\n HINT. The strength of pt comes from the possibility to receive " ++ - "\n the argument from a pipeline, and altering it by the -transform flag." ++ - "\n flags:" ++ - "\n -transform transform the result by this term processor" ++ - "\n -number generate this number of terms at most" ++ - "\n examples:" ++ - "\n p \"zero is even\" | pt -transform=solve -- solve ?'s in parse result" ++ - "\n" ++ - "\n* st, show_tree: st Tree" ++ - "\n Prints the tree as a string. Unlike pt, this command cannot be" ++ - "\n used in a pipe to produce a tree, since its output is a string." ++ - "\n flags:" ++ - "\n -printer show the tree in a special format (-printer=xml supported)" ++ - "\n" ++ - "\nwt, wrap_tree: wt Fun" ++ - "\n Wraps the tree as the sole argument of Fun." ++ - "\n flags:" ++ - "\n -c compute the resulting new tree to normal form" ++ - "\n" ++ - "\nvt, visualize_tree: vt Tree" ++ - "\n Shows the abstract syntax tree via dot and gv (via temporary files" ++ - "\n grphtmp.dot, grphtmp.ps)." ++ - "\n flags:" ++ - "\n -c show categories only (no functions)" ++ - "\n -f show functions only (no categories)" ++ - "\n -g show as graph (sharing uses of the same function)" ++ - "\n -o just generate the .dot file" ++ - "\n examples:" ++ - "\n p \"hello world\" | vt -o | wf my.dot ;; ! open -a GraphViz my.dot" ++ - "\n -- This writes the parse tree into my.dot and opens the .dot file" ++ - "\n -- with another application without generating .ps." ++ - "\n" ++ - "\n-- subshells" ++ - "\n" ++ - "\nes, editing_session: es" ++ - "\n Opens an interactive editing session." ++ - "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ - "\n options:" ++ - "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ - "\n" ++ - "\nts, translation_session: ts" ++ - "\n Translates input lines from any of the actual languages to all other ones." ++ - "\n To exit, type a full stop (.) alone on a line." ++ - "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ - "\n HINT: Set -parser and -lexer locally in each grammar." ++ - "\n options:" ++ - "\n -f Fudget GUI (necessary for Unicode; only available in X Windows)" ++ - "\n -lang prepend translation results with language names" ++ - "\n flags:" ++ - "\n -cat the parser category" ++ - "\n examples:" ++ - "\n ts -cat=Numeral -lang -- translate numerals, show language names" ++ - "\n" ++ - "\ntq, translation_quiz: tq Lang Lang" ++ - "\n Random-generates translation exercises from Lang1 to Lang2," ++ - "\n keeping score of success." ++ - "\n To interrupt, type a full stop (.) alone on a line." ++ - "\n HINT: Set -parser and -lexer locally in each grammar." ++ - "\n flags:" ++ - "\n -cat" ++ - "\n examples:" ++ - "\n tq -cat=NP TestResourceEng TestResourceSwe -- quiz for NPs" ++ - "\n" ++ - "\ntl, translation_list: tl Lang Lang" ++ - "\n Random-generates a list of ten translation exercises from Lang1" ++ - "\n to Lang2. The number can be changed by a flag." ++ - "\n HINT: use wf to save the exercises in a file." ++ - "\n flags:" ++ - "\n -cat" ++ - "\n -number" ++ - "\n examples:" ++ - "\n tl -cat=NP TestResourceEng TestResourceSwe -- quiz list for NPs" ++ - "\n" ++ - "\nmq, morphology_quiz: mq" ++ - "\n Random-generates morphological exercises," ++ - "\n keeping score of success." ++ - "\n To interrupt, type a full stop (.) alone on a line." ++ - "\n HINT: use printname judgements in your grammar to" ++ - "\n produce nice expressions for desired forms." ++ - "\n flags:" ++ - "\n -cat" ++ - "\n -lang" ++ - "\n examples:" ++ - "\n mq -cat=N -lang=TestResourceSwe -- quiz for Swedish nouns" ++ - "\n" ++ - "\nml, morphology_list: ml" ++ - "\n Random-generates a list of ten morphological exercises," ++ - "\n keeping score of success. The number can be changed with a flag." ++ - "\n HINT: use wf to save the exercises in a file." ++ - "\n flags:" ++ - "\n -cat" ++ - "\n -lang" ++ - "\n -number" ++ - "\n examples:" ++ - "\n ml -cat=N -lang=TestResourceSwe -- quiz list for Swedish nouns" ++ - "\n" ++ - "\n" ++ - "\n-- IO related commands" ++ - "\n" ++ - "\nrf, read_file: rf File" ++ - "\n Returns the contents of File as a String; error if File does not exist." ++ - "\n" ++ - "\nwf, write_file: wf File String" ++ - "\n Writes String into File; File is created if it does not exist." ++ - "\n N.B. the command overwrites File without a warning." ++ - "\n" ++ - "\naf, append_file: af File" ++ - "\n Writes String into the end of File; File is created if it does not exist." ++ - "\n" ++ - "\n* tg, transform_grammar: tg File" ++ - "\n Reads File, parses as a grammar, " ++ - "\n but instead of compiling further, prints it. " ++ - "\n The environment is not changed. When parsing the grammar, the same file" ++ - "\n name suffixes are supported as in the i command." ++ - "\n HINT: use this command to print the grammar in " ++ - "\n another format (the -printer flag); pipe it to wf to save this format." ++ - "\n flags:" ++ - "\n -printer (only -printer=latex supported currently)" ++ - "\n" ++ - "\n* cl, convert_latex: cl File" ++ - "\n Reads File, which is expected to be in LaTeX form." ++ - "\n Three environments are treated in special ways:" ++ - "\n \\begGF - \\end{verbatim}, which contains GF judgements," ++ - "\n \\begTGF - \\end{verbatim}, which contains a GF expression (displayed)" ++ - "\n \\begInTGF - \\end{verbatim}, which contains a GF expressions (inlined)." ++ - "\n Moreover, certain macros should be included in the file; you can" ++ - "\n get those macros by applying 'tg -printer=latex foo.gf' to any grammar" ++ - "\n foo.gf. Notice that the same File can be imported as a GF grammar," ++ - "\n consisting of all the judgements in \\begGF environments." ++ - "\n HINT: pipe with 'wf Foo.tex' to generate a new Latex file." ++ - "\n" ++ - "\nsa, speak_aloud: sa String" ++ - "\n Uses the Flite speech generator to produce speech for String." ++ - "\n Works for American English spelling. " ++ - "\n examples:" ++ - "\n h | sa -- listen to the list of commands" ++ - "\n gr -cat=S | l | sa -- generate a random sentence and speak it aloud" ++ - "\n" ++ - "\nsi, speech_input: si" ++ - "\n Uses an ATK speech recognizer to get speech input. " ++ - "\n flags:" ++ - "\n -lang: The grammar to use with the speech recognizer." ++ - "\n -cat: The grammar category to get input in." ++ - "\n -language: Use acoustic model and dictionary for this language." ++ - "\n -number: The number of utterances to recognize." ++ - "\n" ++ - "\nh, help: h Command?" ++ - "\n Displays the paragraph concerning the command from this help file." ++ - "\n Without the argument, shows the first lines of all paragraphs." ++ - "\n options" ++ - "\n -all show the whole help file" ++ - "\n -defs show user-defined commands and terms" ++ - "\n -FLAG show the values of FLAG (works for grammar-independent flags)" ++ - "\n examples:" ++ - "\n h print_grammar -- show all information on the pg command" ++ - "\n" ++ - "\nq, quit: q" ++ - "\n Exits GF." ++ - "\n HINT: you can use 'ph | wf history' to save your session." ++ - "\n" ++ - "\n!, system_command: ! String" ++ - "\n Issues a system command. No value is returned to GF." ++ - "\n example:" ++ - "\n ! ls" ++ - "\n" ++ - "\n?, system_command: ? String" ++ - "\n Issues a system command that receives its arguments from GF pipe" ++ - "\n and returns a value to GF." ++ - "\n example:" ++ - "\n h | ? 'wc -l' | p -cat=Num" ++ - "\n" ++ - "\n" ++ - "\n-- Flags. The availability of flags is defined separately for each command." ++ - "\n" ++ - "\n-cat, category in which parsing is performed." ++ - "\n The default is S." ++ - "\n" ++ - "\n-depth, the search depth in e.g. random generation." ++ - "\n The default depends on application." ++ - "\n" ++ - "\n-filter, operation performed on a string. The default is identity." ++ - "\n -filter=identity no change" ++ - "\n -filter=erase erase the text" ++ - "\n -filter=take100 show the first 100 characters" ++ - "\n -filter=length show the length of the string" ++ - "\n -filter=text format as text (punctuation, capitalization)" ++ - "\n -filter=code format as code (spacing, indentation)" ++ - "\n" ++ - "\n-lang, grammar used when executing a grammar-dependent command." ++ - "\n The default is the last-imported grammar." ++ - "\n" ++ - "\n-language, voice used by Festival as its --language flag in the sa command. " ++ - "\n The default is system-dependent. " ++ - "\n" ++ - "\n-length, the maximum number of characters shown of a string. " ++ - "\n The default is unlimited." ++ - "\n" ++ - "\n-lexer, tokenization transforming a string into lexical units for a parser." ++ - "\n The default is words." ++ - "\n -lexer=words tokens are separated by spaces or newlines" ++ - "\n -lexer=literals like words, but GF integer and string literals recognized" ++ - "\n -lexer=vars like words, but \"x\",\"x_...\",\"$...$\" as vars, \"?...\" as meta" ++ - "\n -lexer=chars each character is a token" ++ - "\n -lexer=code use Haskell's lex" ++ - "\n -lexer=codevars like code, but treat unknown words as variables, ?? as meta " ++ - "\n -lexer=textvars like text, but treat unknown words as variables, ?? as meta " ++ - "\n -lexer=text with conventions on punctuation and capital letters" ++ - "\n -lexer=codelit like code, but treat unknown words as string literals" ++ - "\n -lexer=textlit like text, but treat unknown words as string literals" ++ - "\n -lexer=codeC use a C-like lexer" ++ - "\n -lexer=ignore like literals, but ignore unknown words" ++ - "\n -lexer=subseqs like ignore, but then try all subsequences from longest" ++ - "\n" ++ - "\n-number, the maximum number of generated items in a list. " ++ - "\n The default is unlimited." ++ - "\n" ++ - "\n-optimize, optimization on generated code." ++ - "\n The default is share for concrete, none for resource modules." ++ - "\n Each of the flags can have the suffix _subs, which performs" ++ - "\n common subexpression elimination after the main optimization." ++ - "\n Thus, -optimize=all_subs is the most aggressive one. The _subs" ++ - "\n strategy only works in GFC, and applies therefore in concrete but" ++ - "\n not in resource modules." ++ - "\n -optimize=share share common branches in tables" ++ - "\n -optimize=parametrize first try parametrize then do share with the rest" ++ - "\n -optimize=values represent tables as courses-of-values" ++ - "\n -optimize=all first try parametrize then do values with the rest" ++ - "\n -optimize=none no optimization" ++ - "\n" ++ - "\n-parser, parsing strategy. The default is chart. If -cfg or -mcfg are" ++ - "\n selected, only bottomup and topdown are recognized." ++ - "\n -parser=chart bottom-up chart parsing" ++ - "\n -parser=bottomup a more up to date bottom-up strategy" ++ - "\n -parser=topdown top-down strategy" ++ - "\n -parser=old an old bottom-up chart parser" ++ - "\n" ++ - "\n-printer, format in which the grammar is printed. The default is" ++ - "\n gfc. Those marked with M are (only) available for pm, the rest" ++ - "\n for pg." ++ - "\n -printer=gfc GFC grammar" ++ - "\n -printer=gf GF grammar" ++ - "\n -printer=old old GF grammar" ++ - "\n -printer=cf context-free grammar, with profiles" ++ - "\n -printer=bnf context-free grammar, without profiles" ++ - "\n -printer=lbnf labelled context-free grammar for BNF Converter" ++ - "\n -printer=plbnf grammar for BNF Converter, with precedence levels" ++ - "\n *-printer=happy source file for Happy parser generator (use lbnf!)" ++ - "\n -printer=haskell abstract syntax in Haskell, with transl to/from GF" ++ - "\n -printer=haskell_gadt abstract syntax GADT in Haskell, with transl to/from GF" ++ - "\n -printer=morpho full-form lexicon, long format" ++ - "\n *-printer=latex LaTeX file (for the tg command)" ++ - "\n -printer=fullform full-form lexicon, short format" ++ - "\n *-printer=xml XML: DTD for the pg command, object for st" ++ - "\n -printer=old old GF: file readable by GF 1.2" ++ - "\n -printer=stat show some statistics of generated GFC" ++ - "\n -printer=probs show probabilities of all functions" ++ - "\n -printer=gsl Nuance GSL speech recognition grammar" ++ - "\n -printer=jsgf Java Speech Grammar Format" ++ - "\n -printer=jsgf_sisr_old Java Speech Grammar Format with semantic tags in " ++ - "\n SISR WD 20030401 format" ++ - "\n -printer=srgs_abnf SRGS ABNF format" ++ - "\n -printer=srgs_abnf_non_rec SRGS ABNF format, without any recursion." ++ - "\n -printer=srgs_abnf_sisr_old SRGS ABNF format, with semantic tags in" ++ - "\n SISR WD 20030401 format" ++ - "\n -printer=srgs_xml SRGS XML format" ++ - "\n -printer=srgs_xml_non_rec SRGS XML format, without any recursion." ++ - "\n -printer=srgs_xml_prob SRGS XML format, with weights" ++ - "\n -printer=srgs_xml_sisr_old SRGS XML format, with semantic tags in" ++ - "\n SISR WD 20030401 format" ++ - "\n -printer=vxml Generate a dialogue system in VoiceXML." ++ - "\n -printer=slf a finite automaton in the HTK SLF format" ++ - "\n -printer=slf_graphviz the same automaton as slf, but in Graphviz format" ++ - "\n -printer=slf_sub a finite automaton with sub-automata in the " ++ - "\n HTK SLF format" ++ - "\n -printer=slf_sub_graphviz the same automaton as slf_sub, but in " ++ - "\n Graphviz format" ++ - "\n -printer=fa_graphviz a finite automaton with labelled edges" ++ - "\n -printer=regular a regular grammar in a simple BNF" ++ - "\n -printer=unpar a gfc grammar with parameters eliminated" ++ - "\n -printer=functiongraph abstract syntax functions in 'dot' format" ++ - "\n -printer=typegraph abstract syntax categories in 'dot' format" ++ - "\n -printer=transfer Transfer language datatype (.tr file format)" ++ - "\n -printer=cfg-prolog M cfg in prolog format (also pg)" ++ - "\n -printer=gfc-prolog M gfc in prolog format (also pg)" ++ - "\n -printer=gfcm M gfcm file (default for pm)" ++ - "\n -printer=graph M module dependency graph in 'dot' (graphviz) format" ++ - "\n -printer=header M gfcm file with header (for GF embedded in Java)" ++ - "\n -printer=js M JavaScript type annotator and linearizer" ++ - "\n -printer=mcfg-prolog M mcfg in prolog format (also pg)" ++ - "\n -printer=missing M the missing linearizations of each concrete" ++ - "\n" ++ - "\n-startcat, like -cat, but used in grammars (to avoid clash with keyword cat)" ++ - "\n" ++ - "\n-transform, transformation performed on a syntax tree. The default is identity." ++ - "\n -transform=identity no change" ++ - "\n -transform=compute compute by using definitions in the grammar" ++ - "\n -transform=nodup return the term only if it has no constants duplicated" ++ - "\n -transform=nodupatom return the term only if it has no atomic constants duplicated" ++ - "\n -transform=typecheck return the term only if it is type-correct" ++ - "\n -transform=solve solve metavariables as derived refinements" ++ - "\n -transform=context solve metavariables by unique refinements as variables" ++ - "\n -transform=delete replace the term by metavariable" ++ - "\n" ++ - "\n-unlexer, untokenization transforming linearization output into a string." ++ - "\n The default is unwords." ++ - "\n -unlexer=unwords space-separated token list (like unwords)" ++ - "\n -unlexer=text format as text: punctuation, capitals, paragraph

" ++ - "\n -unlexer=code format as code (spacing, indentation)" ++ - "\n -unlexer=textlit like text, but remove string literal quotes" ++ - "\n -unlexer=codelit like code, but remove string literal quotes" ++ - "\n -unlexer=concat remove all spaces" ++ - "\n -unlexer=bind like identity, but bind at \"&+\"" ++ - "\n" ++ - "\n-mark, marking of parts of tree in linearization. The default is none." ++ - "\n -mark=metacat append \"+CAT\" to every metavariable, showing its category" ++ - "\n -mark=struct show tree structure with brackets" ++ - "\n -mark=java show tree structure with XML tags (used in gfeditor)" ++ - "\n" ++ - "\n-coding, Some grammars are in UTF-8, some in isolatin-1." ++ - "\n If the letters \228 (a-umlaut) and \246 (o-umlaut) look strange, either" ++ - "\n change your terminal to isolatin-1, or rewrite the grammar with" ++ - "\n 'pg -utf8'. For Windows you also may have to change your font to TrueType." ++ - "\n" ++ - "\n-- *: Commands and options marked with * are not currently implemented." ++ - [] diff --git a/src-3.0/GF/Shell/JGF.hs b/src-3.0/GF/Shell/JGF.hs deleted file mode 100644 index 0ff678809..000000000 --- a/src-3.0/GF/Shell/JGF.hs +++ /dev/null @@ -1,89 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : JGF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/03 22:44:36 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- GF editing session controlled by e.g. a Java program. AR 16\/11\/2001 ------------------------------------------------------------------------------ - -module GF.Shell.JGF where - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Text.Unicode - -import GF.API.IOGrammar -import GF.Infra.Option -import GF.Compile.ShellState -import GF.UseGrammar.Session -import GF.Shell.Commands -import GF.Shell.CommandL -import GF.Text.UTF8 - -import Control.Monad (foldM) -import System - - - --- GF editing session controlled by e.g. a Java program. AR 16/11/2001 - --- | the Boolean is a temporary hack to have two parallel GUIs -sessionLineJ :: Bool -> ShellState -> IO () -sessionLineJ isNew env = do - putStrLnFlush $ initEditMsgJavaX env - let env' = addGlobalOptions (options [sizeDisplay "short",beSilent]) env - editLoopJnewX isNew env' (initSState) - --- | this is the real version, with XML --- --- the Boolean is a temporary hack to have two parallel GUIs -editLoopJnewX :: Bool -> CEnv -> SState -> IO () -editLoopJnewX isNew env state = do - mscs <- getCommandUTF (isCEnvUTF8 env state) ---- - let (ms,cs) = unzip mscs - m = unlines ms --- ? - if null cs - then editLoopJnewX isNew env state - else - case cs of - [CQuit] -> return () - _ -> do - (env',state') <- foldM exec (env,state) cs - let inits = initAndEditMsgJavaX isNew env' state' m - let - package = case last cs of - CCEnvImport _ -> inits - CCEnvEmptyAndImport _ -> inits - CCEnvOpenTerm _ -> inits - CCEnvOpenString _ -> inits - CCEnvEmpty -> initEditMsgJavaX env' - _ -> displaySStateJavaX isNew env' state' m - putStrLnFlush package - editLoopJnewX isNew env' state' - where - exec (env,state) c = do - execCommand env c state - -welcome :: String -welcome = - "An experimental GF Editor for Java." ++ - "(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL." - -initEditMsgJavaX :: CEnv -> String -initEditMsgJavaX env = encodeUTF8 $ mkUnicode $ unlines $ tagXML "gfinit" $ - tagsXML "newcat" [["n" +++ cat] | (_,cat) <- newCatMenu env] ++ - tagXML "topic" [abstractName env] ++ - tagXML "language" [prLanguage langAbstract] ++ - concat [tagAttrXML "language" ("file",file) [prLanguage lang] | - (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)] - - -initAndEditMsgJavaX :: Bool -> CEnv -> SState -> String -> String -initAndEditMsgJavaX isNew env state m = - initEditMsgJavaX env ++++ displaySStateJavaX isNew env state m diff --git a/src-3.0/GF/Shell/PShell.hs b/src-3.0/GF/Shell/PShell.hs deleted file mode 100644 index 68cb4d629..000000000 --- a/src-3.0/GF/Shell/PShell.hs +++ /dev/null @@ -1,174 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PShell --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/06 14:21:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.28 $ --- --- parsing GF shell commands. AR 11\/11\/2001 ------------------------------------------------------------------------------ - -module GF.Shell.PShell where - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Compile.ShellState -import GF.Shell.ShellCommands -import GF.Shell -import GF.Infra.Option -import GF.Compile.PGrammar (pzIdent, pTrm) --- (string2formsAndTerm) -import GF.API -import GF.System.Arch (fetchCommand) -import GF.UseGrammar.Tokenize (wordsLits) - -import Data.Char (isDigit, isSpace) -import System.IO.Error - --- parsing GF shell commands. AR 11/11/2001 - --- | getting a sequence of command lines as input -getCommandLines :: HState -> IO (String,[CommandLine]) -getCommandLines st = do - s <- fetchCommand "> " - return (s,pCommandLines st s) - -getCommandLinesBatch :: HState -> IO (String,[CommandLine]) -getCommandLinesBatch st = do - s <- catch getLine (\e -> if isEOFError e then return "q" else ioError e) - return $ (s,pCommandLines st s) - -pCommandLines :: HState -> String -> [CommandLine] -pCommandLines st = - map (pCommandLine st) . concatMap (chunks ";;" . wordsLits) . lines - --- | Remove single or double quotes around a string -unquote :: String -> String -unquote (x:xs@(_:_)) | x `elem` "\"'" && x == last xs = init xs -unquote s = s - -pCommandLine :: HState -> [String] -> CommandLine -pCommandLine st (c@('%':_):args) = pCommandLine st $ resolveShMacro st c args -pCommandLine st (dc:c:def) | abbrevCommand dc == "dc" = ((CDefineCommand c def, noOptions),AUnit,[]) -pCommandLine st s = pFirst (chks s) where - pFirst cos = case cos of - (c,os,[a]) : cs -> ((c,os), a, pCont cs) - _ -> ((CVoid,noOptions), AError "no parse", []) - pCont cos = case cos of - (c,os,_) : cs -> (c,os) : pCont cs - _ -> [] - chks = map (pCommandOpt st) . chunks "|" - -pCommandOpt :: HState -> [String] -> (Command, Options, [CommandArg]) -pCommandOpt _ (w:ws) = let - (os, co) = getOptions "-" ws - (comm, args) = pCommand (abbrevCommand w:co) - in - (comm, os, args) -pCommandOpt _ s = (CVoid, noOptions, [AError "no parse"]) - -pInputString :: String -> [CommandArg] -pInputString s = case s of - ('"':_:_) | last s == '"' -> [AString (read s)] - _ -> [AError "illegal string"] - --- | command @rl@ can be written @remove_language@ etc. -abbrevCommand :: String -> String -abbrevCommand = hds . words . map u2sp where - u2sp c = if c=='_' then ' ' else c - hds s = case s of - [w@[_,_]] -> w - _ -> map head s - -pCommand :: [String] -> (Command, [CommandArg]) -pCommand ws = case ws of - - "i" : f : [] -> aUnit (CImport (unquote f)) - "rl" : l : [] -> aUnit (CRemoveLanguage (language l)) - "e" : [] -> aUnit CEmptyState - "cm" : a : [] -> aUnit (CChangeMain (Just (pzIdent a))) - "cm" : [] -> aUnit (CChangeMain Nothing) - "s" : [] -> aUnit CStripState - "tg" : f : [] -> aUnit (CTransformGrammar f) - "cl" : f : [] -> aUnit (CConvertLatex f) - - "ph" : [] -> aUnit CPrintHistory - "dt" : f : t -> aTerm (CDefineTerm (unquote f)) t - - "l" : s -> aTermLi CLinearize s - - "p" : s -> aString CParse s - "t" : i:o: s -> aString (CTranslate (language i) (language o)) s - "gr" : [] -> aUnit CGenerateRandom - "gr" : t -> aTerm CGenerateRandom t - "gt" : [] -> aUnit CGenerateTrees - "gt" : t -> aTerm CGenerateTrees t - "pt" : s -> aTerm CPutTerm s - "wt" : f : s -> aTerm (CWrapTerm (pzIdent f)) s - "at" : f : s -> aTerm (CApplyTransfer (pmIdent f)) s - "ma" : s -> aString CMorphoAnalyse s - "tt" : s -> aString CTestTokenizer s - "cc" : s -> aUnit $ CComputeConcrete $ unwords s - "so" : s -> aUnit $ CShowOpers $ unwords s - "tb" : [] -> aUnit CTreeBank - "ut" : s -> aString CLookupTreebank s - - "tq" : i:o:[] -> aUnit (CTranslationQuiz (language i) (language o)) - "tl":i:o:[] -> aUnit (CTranslationList (language i) (language o)) - "mq" : [] -> aUnit CMorphoQuiz - "ml" : [] -> aUnit CMorphoList - - "wf" : f : s -> aString (CWriteFile (unquote f)) s - "af" : f : s -> aString (CAppendFile (unquote f)) s - "rf" : f : [] -> aUnit (CReadFile (unquote f)) - "sa" : s -> aString CSpeakAloud s - "si" : [] -> aUnit CSpeechInput - "ps" : s -> aString CPutString s - "st" : s -> aTerm CShowTerm s - "!" : s -> aUnit (CSystemCommand (unwords s)) - "?" : s : x -> aString (CSystemCommand (unquote s)) x - "sc" : s -> aUnit (CSystemCommand (unwords s)) - "g" : f : s -> aString (CGrep (unquote f)) s - - "sf" : l : [] -> aUnit (CSetLocalFlag (language l)) - "sf" : [] -> aUnit CSetFlag - - "pg" : [] -> aUnit CPrintGrammar - "pi" : c : [] -> aUnit $ CPrintInformation (pzIdent c) - - "pj" : [] -> aUnit CPrintGramlet - "pxs" : [] -> aUnit CPrintCanonXMLStruct - "px" : [] -> aUnit CPrintCanonXML - "pm" : [] -> aUnit CPrintMultiGrammar - "vg" : [] -> aUnit CShowGrammarGraph - "vt" : s -> aTerm CShowTreeGraph s - "sg" : [] -> aUnit CPrintSourceGrammar - "po" : [] -> aUnit CPrintGlobalOptions - "pl" : [] -> aUnit CPrintLanguages - "h" : c : [] -> aUnit $ CHelp (Just (abbrevCommand c)) - "h" : [] -> aUnit $ CHelp Nothing - - "q" : [] -> aImpure ICQuit - "eh" : f : [] -> aImpure (ICExecuteHistory f) - n : [] | all isDigit n -> aImpure (ICEarlierCommand (readIntArg n)) - - "es" : [] -> aImpure ICEditSession - "ts" : [] -> aImpure ICTranslateSession - "r" : [] -> aImpure ICReload - _ -> (CVoid, []) - - where - aString c ss = (c, pInputString (unwords ss)) - aTerm c ss = (c, [ASTrm $ unwords ss]) ---- [ASTrms [s2t (unwords ss)]]) - aUnit c = (c, [AUnit]) - aImpure = aUnit . CImpure - - aTermLi c ss = (c [], [ASTrm $ unwords ss]) - ---- (c forms, [ASTrms [term]]) where - ---- (forms,term) = ([], s2t (unwords ss)) ----string2formsAndTerm(unwords ss) - pmIdent m = case span (/='.') m of - (k,_:f) -> (Just (pzIdent k), pzIdent f) - _ -> (Nothing,pzIdent m) diff --git a/src-3.0/GF/Shell/ShellCommands.hs b/src-3.0/GF/Shell/ShellCommands.hs deleted file mode 100644 index 70238817b..000000000 --- a/src-3.0/GF/Shell/ShellCommands.hs +++ /dev/null @@ -1,246 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ShellCommands --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.46 $ --- --- The datatype of shell commands and the list of their options. ------------------------------------------------------------------------------ - -module GF.Shell.ShellCommands where - -import qualified GF.Infra.Ident as I -import GF.Compile.ShellState -import GF.UseGrammar.Custom -import GF.Grammar.PrGrammar - -import GF.Infra.Option -import GF.Data.Operations -import GF.Infra.Modules - -import Data.Char (isDigit) -import Control.Monad (mplus) - --- shell commands and their options --- moved to separate module and added option check: AR 27/5/2004 ---- TODO: single source for ---- (1) command interpreter (2) option check (3) help file - -data Command = - CImport FilePath - | CRemoveLanguage Language - | CEmptyState - | CChangeMain (Maybe I.Ident) - | CStripState - | CTransformGrammar FilePath - | CConvertLatex FilePath - - | CDefineCommand String [String] - | CDefineTerm String - - | CLinearize [()] ---- parameters - | CParse - | CTranslate Language Language - | CGenerateRandom - | CGenerateTrees - | CTreeBank - | CPutTerm - | CWrapTerm I.Ident - | CApplyTransfer (Maybe I.Ident, I.Ident) - | CMorphoAnalyse - | CTestTokenizer - | CComputeConcrete String - | CShowOpers String - - | CLookupTreebank - - | CTranslationQuiz Language Language - | CTranslationList Language Language - | CMorphoQuiz - | CMorphoList - - | CReadFile FilePath - | CWriteFile FilePath - | CAppendFile FilePath - | CSpeakAloud - | CSpeechInput - | CPutString - | CShowTerm - | CSystemCommand String - | CGrep String - - | CSetFlag - | CSetLocalFlag Language - - | CPrintGrammar - | CPrintGlobalOptions - | CPrintLanguages - | CPrintInformation I.Ident - | CPrintMultiGrammar - | CPrintSourceGrammar - | CShowGrammarGraph - | CShowTreeGraph - | CPrintGramlet - | CPrintCanonXML - | CPrintCanonXMLStruct - | CPrintHistory - | CHelp (Maybe String) - - | CImpure ImpureCommand - - | CVoid - --- to isolate the commands that are executed on top level -data ImpureCommand = - ICQuit - | ICExecuteHistory FilePath - | ICEarlierCommand Int - | ICEditSession - | ICTranslateSession - | ICReload - -type CommandOpt = (Command, Options) - --- the top-level option warning action - -checkOptions :: ShellState -> (Command,Options) -> IO () -checkOptions sh (co, Opts opts) = do - let (_,s) = errVal ([],"option check failed") $ mapErr check opts - if (null s) then return () - else putStr "WARNING: " >> putStrLn s - where - check = isValidOption sh co - -isValidOption :: ShellState -> Command -> Option -> Err () -isValidOption st co op = case op of - Opt (o,[]) -> - testErr (elem o $ optsOf co) ("invalid option:" +++ prOpt op) - Opt (o,[x]) -> do - testErr (elem o (flagsOf co)) ("invalid flag:" +++ o) - testValidFlag st co o x - _ -> Bad $ "impossible option" +++ prOpt op - where - optsOf co = ("tr" :) $ fst $ optionsOfCommand co - flagsOf co = snd $ optionsOfCommand co - -testValidFlag :: ShellState -> Command -> OptFunId -> String -> Err () -testValidFlag st co f x = case f of - "cat" -> testIn (map prQIdent_ (allCategories st)) - "lang" -> testIn (map prt (allLanguages st)) - "transfer" -> testIn (map prt (allTransfers st)) - "res" -> testIn (map prt (allResources (srcModules st))) - "number" -> testN - "printer" -> case co of - CPrintGrammar -> testInc customGrammarPrinter - CPrintMultiGrammar -> testInc customMultiGrammarPrinter - CSetFlag -> testInc customGrammarPrinter `mplus` - testInc customMultiGrammarPrinter - "lexer" -> testInc customTokenizer - "unlexer" -> testInc customUntokenizer - "depth" -> testN - "rawtrees"-> testN - "parser" -> testInc customParser - -- hack for the -newer parsers: (to be changed in the future) - -- `mplus` testIn (words "mcfg mcfg-bottomup mcfg-topdown cfg cfg-bottomup cfg-topdown bottomup topdown") - -- if not(null x) && head x `elem` "mc" then return () else Bad "" - "alts" -> testN - "transform" -> testInc customTermCommand - "filter" -> testInc customStringCommand - "length" -> testN - "optimize"-> testIn $ words "parametrize values all share none" - "conversion" -> testIn $ words "strict nondet finite finite2 finite3 singletons finite-strict finite-singletons" - _ -> return () - where - testInc ci = - let vs = snd (customInfo ci) in testIn vs - testIn vs = - if elem x vs - then return () - else Bad ("flag:" +++ f +++ "invalid value:" +++ x ++++ - "possible values:" +++ unwords vs) - testN = - if all isDigit x - then return () - else Bad ("flag:" +++ f +++ "invalid value:" +++ x ++++ - "expected integer") - - -optionsOfCommand :: Command -> ([String],[String]) -optionsOfCommand co = case co of - CSetFlag -> - both "utf8 table struct record all multi" - "cat lang lexer parser number depth rawtrees unlexer optimize path conversion printer" - CImport _ -> - both "old v s src make gfc retain docf nocf nocheckcirc cflexer noemit o make ex prob treebank" - "abs cnc res path optimize conversion cat preproc probs noparse" - CRemoveLanguage _ -> none - CEmptyState -> none - CStripState -> none - CTransformGrammar _ -> flags "printer" - CConvertLatex _ -> none - CLinearize _ -> both "utf8 table struct record all multi" "lang number unlexer mark" - CParse -> - both "ambiguous fail cut new newer old overload cfg mcfg fcfg n ign raw v lines all prob" - "cat lang lexer parser number rawtrees" - CTranslate _ _ -> opts "cat lexer parser" - CGenerateRandom -> both "cf prob" "cat lang number depth atoms noexpand doexpand" - CGenerateTrees -> both "metas" "atoms depth alts cat lang number noexpand doexpand" - CPutTerm -> flags "transform number" - CTreeBank -> opts "c xml trees all table record" - CLookupTreebank -> both "assocs raw strings trees" "treebank" - CWrapTerm _ -> opts "c" - CApplyTransfer _ -> flags "lang transfer" - CMorphoAnalyse -> both "short status" "lang" - CTestTokenizer -> flags "lexer" - CComputeConcrete _ -> both "table" "res" - CShowOpers _ -> flags "res" - - CTranslationQuiz _ _ -> flags "cat" - CTranslationList _ _ -> flags "cat number" - CMorphoQuiz -> flags "cat lang" - CMorphoList -> flags "cat lang number" - - CReadFile _ -> none - CWriteFile _ -> none - CAppendFile _ -> none - CSpeakAloud -> flags "language" - CSpeechInput -> flags "lang cat language number" - - CPutString -> both "utf8" "filter length" - CShowTerm -> flags "printer" - CShowTreeGraph -> opts "c f g o" - CSystemCommand _ -> none - CGrep _ -> opts "v" - - CPrintGrammar -> both "utf8" "printer lang startcat" - CPrintMultiGrammar -> both "utf8 utf8id" "printer" - CPrintSourceGrammar -> both "utf8" "printer" - - CHelp _ -> opts "all alts atoms coding defs filter length lexer unlexer printer probs transform depth number cat" - - CImpure ICEditSession -> both "f" "file" - CImpure ICTranslateSession -> both "f langs" "cat" - - _ -> none - -{- - CSetLocalFlag Language - CPrintGlobalOptions - CPrintLanguages - CPrintInformation I.Ident - CPrintGramlet - CPrintCanonXML - CPrintCanonXMLStruct - CPrintHistory - CVoid --} - where - flags fs = ([],words fs) - opts fs = (words fs,[]) - both os fs = (words os,words fs) - none = ([],[]) diff --git a/src-3.0/GF/Shell/SubShell.hs b/src-3.0/GF/Shell/SubShell.hs deleted file mode 100644 index 5ef0459e5..000000000 --- a/src-3.0/GF/Shell/SubShell.hs +++ /dev/null @@ -1,66 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SubShell --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:46:12 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.9 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Shell.SubShell where - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Compile.ShellState -import GF.Infra.Option -import GF.API - -import GF.Shell.CommandL -import GF.System.ArchEdit - -import Data.List - --- AR 20/4/2000 -- 12/11/2001 - -editSession :: Options -> ShellState -> IO () -editSession opts st - | oElem makeFudget opts = fudlogueEdit font st' - | otherwise = initEditLoop st' (return ()) - where - st' = addGlobalOptions opts st - font = maybe myUniFont mkOptFont $ getOptVal opts useFont - -myUniFont :: String -myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1" - -mkOptFont :: String -> String -mkOptFont = id - -translateSession :: Options -> ShellState -> IO () -translateSession opts st = do - let grs = allStateGrammars st - cat = firstCatOpts opts (firstStateGrammar st) - trans s = unlines $ - if oElem showLang opts then - sort $ [l +++ ":" +++ s | (l,s) <- zip (map (prIdent . cncId) grs) - (translateBetweenAll grs cat s)] - else translateBetweenAll grs cat s - translateLoop opts trans - -translateLoop :: Options -> (String -> String) -> IO () -translateLoop opts trans = do - let fud = oElem makeFudget opts - font = maybe myUniFont mkOptFont $ getOptVal opts useFont - if fud then fudlogueWrite font trans else loopLine - where - loopLine = do - putStrFlush "trans> " - s <- getLine - if s == "." then return () else do - putStrLnFlush $ trans s - loopLine diff --git a/src-3.0/GF/Shell/TeachYourself.hs b/src-3.0/GF/Shell/TeachYourself.hs deleted file mode 100644 index 7e5a8afe2..000000000 --- a/src-3.0/GF/Shell/TeachYourself.hs +++ /dev/null @@ -1,87 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TeachYourself --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:46:13 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- translation and morphology quiz. AR 10\/5\/2000 -- 12\/4\/2002 ------------------------------------------------------------------------------ - -module GF.Shell.TeachYourself where - -import GF.Compile.ShellState -import GF.API -import GF.UseGrammar.Linear -import GF.Grammar.PrGrammar - -import GF.Infra.Option -import GF.System.Arch (myStdGen) -import GF.Data.Operations -import GF.Infra.UseIO - -import System.Random --- (randoms) --- bad import for hbc -import System - --- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 - -teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO () -teachTranslation opts ig og = do - tts <- transTrainList opts ig og infinity - let qas = [ (q, mkAnswer as) | (q,as) <- tts] - teachDialogue qas "Welcome to GF Translation Quiz." - -transTrainList :: - Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])] -transTrainList opts ig og number = do - ts <- randomTreesIO (addOption beSilent opts) ig (fromInteger number) - return $ map mkOne $ ts - where - cat = firstCatOpts opts ig - mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t)) - - -teachMorpho :: Options -> GFGrammar -> IO () -teachMorpho opts ig = useIOE () $ do - tts <- morphoTrainList opts ig infinity - let qas = [ (q, mkAnswer as) | (q,as) <- tts] - ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz." - -morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])] -morphoTrainList opts ig number = do - ts <- ioeIO $ randomTreesIO (addOption beSilent opts) ig (fromInteger number) - gen <- ioeIO $ myStdGen (fromInteger number) - mkOnes gen ts - where - mkOnes gen (t:ts) = do - psss <- ioeErr $ allLinTables True gr cnc t - let pss = concat $ map snd $ concat psss - let (i,gen') = randomR (0, length pss - 1) gen - (ps,ss) <- ioeErr $ pss !? i - (_,ss0) <- ioeErr $ pss !? 0 - let bas = unwords ss0 --- concat $ take 1 ss0 - more <- mkOnes gen' ts - return $ (bas +++ ":" +++ unwords (map prt_ ps), return (unwords ss)) : more - mkOnes gen [] = return [] - - gr = grammar ig - cnc = cncId ig - --- | compare answer to the list of right answers, increase score and give feedback -mkAnswer :: [String] -> String -> (Integer, String) -mkAnswer as s = if (elem (norml s) as) - then (1,"Yes.") - else (0,"No, not" +++ s ++ ", but" ++++ unlines as) - - -norml :: String -> String -norml = unwords . words - --- | the maximal number of precompiled quiz problems -infinity :: Integer -infinity = 123 - diff --git a/src-3.0/GF/Source/SkelGF.hs b/src-3.0/GF/Source/SkelGF.hs deleted file mode 100644 index cb1b84a4e..000000000 --- a/src-3.0/GF/Source/SkelGF.hs +++ /dev/null @@ -1,381 +0,0 @@ -module GF.Source.SkelGF where - --- Haskell module generated by the BNF converter - -import GF.Source.AbsGF -import GF.Source.ErrM -type Result = Err String - -failure :: Show a => a -> Result -failure x = Bad $ "Undefined case: " ++ show x - -transLString :: LString -> Result -transLString x = case x of - LString str -> failure x - - -transPIdent :: PIdent -> Result -transPIdent x = case x of - PIdent str -> failure x - - -transGrammar :: Grammar -> Result -transGrammar x = case x of - Gr moddefs -> failure x - - -transModDef :: ModDef -> Result -transModDef x = case x of - MMain pident0 pident concspecs -> failure x - MModule complmod modtype modbody -> failure x - - -transConcSpec :: ConcSpec -> Result -transConcSpec x = case x of - ConcSpec pident concexp -> failure x - - -transConcExp :: ConcExp -> Result -transConcExp x = case x of - ConcExp pident transfers -> failure x - - -transTransfer :: Transfer -> Result -transTransfer x = case x of - TransferIn open -> failure x - TransferOut open -> failure x - - -transModHeader :: ModHeader -> Result -transModHeader x = case x of - MModule2 complmod modtype modheaderbody -> failure x - - -transModHeaderBody :: ModHeaderBody -> Result -transModHeaderBody x = case x of - MBody2 extend opens -> failure x - MNoBody2 includeds -> failure x - MWith2 included opens -> failure x - MWithBody2 included opens0 opens -> failure x - MWithE2 includeds included opens -> failure x - MWithEBody2 includeds included opens0 opens -> failure x - MReuse2 pident -> failure x - MUnion2 includeds -> failure x - - -transModType :: ModType -> Result -transModType x = case x of - MTAbstract pident -> failure x - MTResource pident -> failure x - MTInterface pident -> failure x - MTConcrete pident0 pident -> failure x - MTInstance pident0 pident -> failure x - MTTransfer pident open0 open -> failure x - - -transModBody :: ModBody -> Result -transModBody x = case x of - MBody extend opens topdefs -> failure x - MNoBody includeds -> failure x - MWith included opens -> failure x - MWithBody included opens0 opens topdefs -> failure x - MWithE includeds included opens -> failure x - MWithEBody includeds included opens0 opens topdefs -> failure x - MReuse pident -> failure x - MUnion includeds -> failure x - - -transExtend :: Extend -> Result -transExtend x = case x of - Ext includeds -> failure x - NoExt -> failure x - - -transOpens :: Opens -> Result -transOpens x = case x of - NoOpens -> failure x - OpenIn opens -> failure x - - -transOpen :: Open -> Result -transOpen x = case x of - OName pident -> failure x - OQualQO qualopen pident -> failure x - OQual qualopen pident0 pident -> failure x - - -transComplMod :: ComplMod -> Result -transComplMod x = case x of - CMCompl -> failure x - CMIncompl -> failure x - - -transQualOpen :: QualOpen -> Result -transQualOpen x = case x of - QOCompl -> failure x - QOIncompl -> failure x - QOInterface -> failure x - - -transIncluded :: Included -> Result -transIncluded x = case x of - IAll pident -> failure x - ISome pident pidents -> failure x - IMinus pident pidents -> failure x - - -transDef :: Def -> Result -transDef x = case x of - DDecl names exp -> failure x - DDef names exp -> failure x - DPatt name patts exp -> failure x - DFull names exp0 exp -> failure x - - -transTopDef :: TopDef -> Result -transTopDef x = case x of - DefCat catdefs -> failure x - DefFun fundefs -> failure x - DefFunData fundefs -> failure x - DefDef defs -> failure x - DefData datadefs -> failure x - DefTrans defs -> failure x - DefPar pardefs -> failure x - DefOper defs -> failure x - DefLincat printdefs -> failure x - DefLindef defs -> failure x - DefLin defs -> failure x - DefPrintCat printdefs -> failure x - DefPrintFun printdefs -> failure x - DefFlag flagdefs -> failure x - DefPrintOld printdefs -> failure x - DefLintype defs -> failure x - DefPattern defs -> failure x - DefPackage pident topdefs -> failure x - DefVars defs -> failure x - DefTokenizer pident -> failure x - - -transCatDef :: CatDef -> Result -transCatDef x = case x of - SimpleCatDef pident ddecls -> failure x - ListCatDef pident ddecls -> failure x - ListSizeCatDef pident ddecls n -> failure x - - -transFunDef :: FunDef -> Result -transFunDef x = case x of - FunDef pidents exp -> failure x - - -transDataDef :: DataDef -> Result -transDataDef x = case x of - DataDef pident dataconstrs -> failure x - - -transDataConstr :: DataConstr -> Result -transDataConstr x = case x of - DataId pident -> failure x - DataQId pident0 pident -> failure x - - -transParDef :: ParDef -> Result -transParDef x = case x of - ParDefDir pident parconstrs -> failure x - ParDefIndir pident0 pident -> failure x - ParDefAbs pident -> failure x - - -transParConstr :: ParConstr -> Result -transParConstr x = case x of - ParConstr pident ddecls -> failure x - - -transPrintDef :: PrintDef -> Result -transPrintDef x = case x of - PrintDef names exp -> failure x - - -transFlagDef :: FlagDef -> Result -transFlagDef x = case x of - FlagDef pident0 pident -> failure x - - -transName :: Name -> Result -transName x = case x of - IdentName pident -> failure x - ListName pident -> failure x - - -transLocDef :: LocDef -> Result -transLocDef x = case x of - LDDecl pidents exp -> failure x - LDDef pidents exp -> failure x - LDFull pidents exp0 exp -> failure x - - -transExp :: Exp -> Result -transExp x = case x of - EIdent pident -> failure x - EConstr pident -> failure x - ECons pident -> failure x - ESort sort -> failure x - EString str -> failure x - EInt n -> failure x - EFloat d -> failure x - EMeta -> failure x - EEmpty -> failure x - EData -> failure x - EList pident exps -> failure x - EStrings str -> failure x - ERecord locdefs -> failure x - ETuple tuplecomps -> failure x - EIndir pident -> failure x - ETyped exp0 exp -> failure x - EProj exp label -> failure x - EQConstr pident0 pident -> failure x - EQCons pident0 pident -> failure x - EApp exp0 exp -> failure x - ETable cases -> failure x - ETTable exp cases -> failure x - EVTable exp exps -> failure x - ECase exp cases -> failure x - EVariants exps -> failure x - EPre exp alterns -> failure x - EStrs exps -> failure x - EConAt pident exp -> failure x - EPatt patt -> failure x - EPattType exp -> failure x - ESelect exp0 exp -> failure x - ETupTyp exp0 exp -> failure x - EExtend exp0 exp -> failure x - EGlue exp0 exp -> failure x - EConcat exp0 exp -> failure x - EAbstr binds exp -> failure x - ECTable binds exp -> failure x - EProd decl exp -> failure x - ETType exp0 exp -> failure x - ELet locdefs exp -> failure x - ELetb locdefs exp -> failure x - EWhere exp locdefs -> failure x - EEqs equations -> failure x - EExample exp str -> failure x - ELString lstring -> failure x - ELin pident -> failure x - - -transExps :: Exps -> Result -transExps x = case x of - NilExp -> failure x - ConsExp exp exps -> failure x - - -transPatt :: Patt -> Result -transPatt x = case x of - PChar -> failure x - PChars str -> failure x - PMacro pident -> failure x - PM pident0 pident -> failure x - PW -> failure x - PV pident -> failure x - PCon pident -> failure x - PQ pident0 pident -> failure x - PInt n -> failure x - PFloat d -> failure x - PStr str -> failure x - PR pattasss -> failure x - PTup patttuplecomps -> failure x - PC pident patts -> failure x - PQC pident0 pident patts -> failure x - PDisj patt0 patt -> failure x - PSeq patt0 patt -> failure x - PRep patt -> failure x - PAs pident patt -> failure x - PNeg patt -> failure x - - -transPattAss :: PattAss -> Result -transPattAss x = case x of - PA pidents patt -> failure x - - -transLabel :: Label -> Result -transLabel x = case x of - LIdent pident -> failure x - LVar n -> failure x - - -transSort :: Sort -> Result -transSort x = case x of - Sort_Type -> failure x - Sort_PType -> failure x - Sort_Tok -> failure x - Sort_Str -> failure x - Sort_Strs -> failure x - - -transBind :: Bind -> Result -transBind x = case x of - BIdent pident -> failure x - BWild -> failure x - - -transDecl :: Decl -> Result -transDecl x = case x of - DDec binds exp -> failure x - DExp exp -> failure x - - -transTupleComp :: TupleComp -> Result -transTupleComp x = case x of - TComp exp -> failure x - - -transPattTupleComp :: PattTupleComp -> Result -transPattTupleComp x = case x of - PTComp patt -> failure x - - -transCase :: Case -> Result -transCase x = case x of - Case patt exp -> failure x - - -transEquation :: Equation -> Result -transEquation x = case x of - Equ patts exp -> failure x - - -transAltern :: Altern -> Result -transAltern x = case x of - Alt exp0 exp -> failure x - - -transDDecl :: DDecl -> Result -transDDecl x = case x of - DDDec binds exp -> failure x - DDExp exp -> failure x - - -transOldGrammar :: OldGrammar -> Result -transOldGrammar x = case x of - OldGr include topdefs -> failure x - - -transInclude :: Include -> Result -transInclude x = case x of - NoIncl -> failure x - Incl filenames -> failure x - - -transFileName :: FileName -> Result -transFileName x = case x of - FString str -> failure x - FIdent pident -> failure x - FSlash filename -> failure x - FDot filename -> failure x - FMinus filename -> failure x - FAddId pident filename -> failure x - - - diff --git a/src-3.0/GF/Source/TestGF.hs b/src-3.0/GF/Source/TestGF.hs deleted file mode 100644 index 1c5da52ab..000000000 --- a/src-3.0/GF/Source/TestGF.hs +++ /dev/null @@ -1,58 +0,0 @@ --- automatically generated by BNF Converter -module Main where - - -import IO ( stdin, hGetContents ) -import System ( getArgs, getProgName ) - -import GF.Source.LexGF -import GF.Source.ParGF -import GF.Source.SkelGF -import GF.Source.PrintGF -import GF.Source.AbsGF - - - - -import GF.Source.ErrM - -type ParseFun a = [Token] -> Err a - -myLLexer = myLexer - -type Verbosity = Int - -putStrV :: Verbosity -> String -> IO () -putStrV v s = if v > 1 then putStrLn s else return () - -runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () -runFile v p f = putStrLn f >> readFile f >>= run v p - -run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () -run v p s = let ts = myLLexer s in case p ts of - Bad s -> do putStrLn "\nParse Failed...\n" - putStrV v "Tokens:" - putStrV v $ show ts - putStrLn s - Ok tree -> do putStrLn "\nParse Successful!" - showTree v tree - - - -showTree :: (Show a, Print a) => Int -> a -> IO () -showTree v tree - = do - putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree - putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree - -main :: IO () -main = do args <- getArgs - case args of - [] -> hGetContents stdin >>= run 2 pGrammar - "-s":fs -> mapM_ (runFile 0 pGrammar) fs - fs -> mapM_ (runFile 2 pGrammar) fs - - - - - diff --git a/src-3.0/GF/Speech/CFGToFiniteState.hs b/src-3.0/GF/Speech/CFGToFiniteState.hs deleted file mode 100644 index 7e6f80ba1..000000000 --- a/src-3.0/GF/Speech/CFGToFiniteState.hs +++ /dev/null @@ -1,265 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CFGToFiniteState --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Approximates CFGs with finite state networks. ------------------------------------------------------------------------------ - -module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular, - MFA(..), MFALabel, cfgToMFA,cfgToFA') where - -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import GF.Data.Utilities -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) -import GF.Conversion.Types -import GF.Infra.Ident (Ident) -import GF.Infra.Option (Options) -import GF.Compile.ShellState (StateGrammar) - -import GF.Speech.FiniteState -import GF.Speech.Graph -import GF.Speech.Relation -import GF.Speech.TransformCFG - -data Recursivity = RightR | LeftR | NotR - -data MutRecSet = MutRecSet { - mrCats :: Set Cat_, - mrNonRecRules :: [CFRule_], - mrRecRules :: [CFRule_], - mrRec :: Recursivity - } - - -type MutRecSets = Map Cat_ MutRecSet - --- --- * Multiple DFA type --- - -type MFALabel a = Symbol String a - -data MFA a = MFA String [(String,DFA (MFALabel a))] - - - -cfgToFA :: Options -> StateGrammar -> DFA Token -cfgToFA opts s = minimize $ compileAutomaton start $ makeSimpleRegular opts s - where start = getStartCatCF opts s - -makeSimpleRegular :: Options -> StateGrammar -> CFRules -makeSimpleRegular opts s = makeRegular $ preprocess $ cfgToCFRules s - where start = getStartCatCF opts s - preprocess = topDownFilter start . bottomUpFilter - . removeCycles - - --- --- * Compile strongly regular grammars to NFAs --- - --- Convert a strongly regular grammar to a finite automaton. -compileAutomaton :: Cat_ -- ^ Start category - -> CFRules - -> NFA Token -compileAutomaton start g = make_fa (g,ns) s [Cat start] f fa - where - (fa,s,f) = newFA_ - ns = mutRecSets g $ mutRecCats False g - --- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\", --- Mark-Jan Nederhof, Advances in Probabilistic and other Parsing Technologies, 2000. -make_fa :: (CFRules,MutRecSets) -> State -> [Symbol Cat_ Token] -> State - -> NFA Token -> NFA Token -make_fa c@(g,ns) q0 alpha q1 fa = - case alpha of - [] -> newTransition q0 q1 Nothing fa - [Tok t] -> newTransition q0 q1 (Just t) fa - [Cat a] -> case Map.lookup a ns of - -- a is recursive - Just n@(MutRecSet { mrCats = ni, mrNonRecRules = nrs, mrRecRules = rs} ) -> - case mrRec n of - RightR -> - -- the set Ni is right-recursive or cyclic - let new = [(getState c, xs, q1) | CFRule c xs _ <- nrs] - ++ [(getState c, xs, getState d) | CFRule c ss _ <- rs, - let (xs,Cat d) = (init ss,last ss)] - in make_fas new $ newTransition q0 (getState a) Nothing fa' - LeftR -> - -- the set Ni is left-recursive - let new = [(q0, xs, getState c) | CFRule c xs _ <- nrs] - ++ [(getState d, xs, getState c) | CFRule c (Cat d:xs) _ <- rs] - in make_fas new $ newTransition (getState a) q1 Nothing fa' - where - (fa',stateMap) = addStatesForCats ni fa - getState x = Map.findWithDefault - (error $ "CFGToFiniteState: No state for " ++ x) - x stateMap - -- a is not recursive - Nothing -> let rs = catRules g a - in foldl' (\f (CFRule _ b _) -> make_fa_ q0 b q1 f) fa rs - (x:beta) -> let (fa',q) = newState () fa - in make_fa_ q beta q1 $ make_fa_ q0 [x] q fa' - where - make_fa_ = make_fa c - make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa_ s1 xs s2 f') fa xs - --- --- * Compile a strongly regular grammar to a DFA with sub-automata --- - -cfgToMFA :: Options -> StateGrammar -> MFA Token -cfgToMFA opts s = buildMFA start $ makeSimpleRegular opts s - where start = getStartCatCF opts s - --- | Build a DFA by building and expanding an MFA -cfgToFA' :: Options -> StateGrammar -> DFA Token -cfgToFA' opts s = mfaToDFA $ cfgToMFA opts s - -buildMFA :: Cat_ -- ^ Start category - -> CFRules -> MFA Token -buildMFA start g = sortSubLats $ removeUnusedSubLats mfa - where fas = compileAutomata g - mfa = MFA start [(c, minimize fa) | (c,fa) <- fas] - -mfaStartDFA :: MFA a -> DFA (MFALabel a) -mfaStartDFA (MFA start subs) = - fromMaybe (error $ "Bad start MFA: " ++ start) $ lookup start subs - -mfaToDFA :: Ord a => MFA a -> DFA a -mfaToDFA mfa@(MFA _ subs) = minimize $ expand $ dfa2nfa $ mfaStartDFA mfa - where - subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs] - getSub l = fromJust $ Map.lookup l subs' - expand (FA (Graph c ns es) s f) - = foldl' expandEdge (FA (Graph c ns []) s f) es - expandEdge fa (f,t,x) = - case x of - Nothing -> newTransition f t Nothing fa - Just (Tok s) -> newTransition f t (Just s) fa - Just (Cat l) -> insertNFA fa (f,t) (expand $ getSub l) - -removeUnusedSubLats :: MFA a -> MFA a -removeUnusedSubLats mfa@(MFA start subs) = MFA start [(c,s) | (c,s) <- subs, isUsed c] - where - usedMap = subLatUseMap mfa - used = growUsedSet (Set.singleton start) - isUsed c = c `Set.member` used - growUsedSet = fix (\s -> foldl Set.union s $ mapMaybe (flip Map.lookup usedMap) $ Set.toList s) - -subLatUseMap :: MFA a -> Map String (Set String) -subLatUseMap (MFA _ subs) = Map.fromList [(c,usedSubLats n) | (c,n) <- subs] - -usedSubLats :: DFA (MFALabel a) -> Set String -usedSubLats fa = Set.fromList [s | (_,_,Cat s) <- transitions fa] - -revMultiMap :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a) -revMultiMap m = Map.fromListWith Set.union [ (y,Set.singleton x) | (x,s) <- Map.toList m, y <- Set.toList s] - --- | Sort sub-networks topologically. -sortSubLats :: MFA a -> MFA a -sortSubLats mfa@(MFA main subs) = MFA main (reverse $ sortLats usedByMap subs) - where - usedByMap = revMultiMap (subLatUseMap mfa) - sortLats _ [] = [] - sortLats ub ls = xs ++ sortLats ub' ys - where (xs,ys) = partition ((==0) . indeg) ls - ub' = Map.map (Set.\\ Set.fromList (map fst xs)) ub - indeg (c,_) = maybe 0 Set.size $ Map.lookup c ub - --- | Convert a strongly regular grammar to a number of finite automata, --- one for each non-terminal. --- The edges in the automata accept tokens, or name another automaton to use. -compileAutomata :: CFRules - -> [(Cat_,NFA (Symbol Cat_ Token))] - -- ^ A map of non-terminals and their automata. -compileAutomata g = [(c, makeOneFA c) | c <- allCats g] - where - mrs = mutRecSets g $ mutRecCats True g - makeOneFA c = make_fa1 mr s [Cat c] f fa - where (fa,s,f) = newFA_ - mr = fromJust (Map.lookup c mrs) - - --- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\", --- Mark-Jan Nederhof, Advances in Probabilistic and other Parsing Technologies, 2000, --- adapted to build a finite automaton for a single (mutually recursive) set only. --- Categories not in the set will result in category-labelled edges. -make_fa1 :: MutRecSet -- ^ The set of (mutually recursive) categories for which - -- we are building the automaton. - -> State -- ^ State to come from - -> [Symbol Cat_ Token] -- ^ Symbols to accept - -> State -- ^ State to end up in - -> NFA (Symbol Cat_ Token) -- ^ FA to add to. - -> NFA (Symbol Cat_ Token) -make_fa1 mr q0 alpha q1 fa = - case alpha of - [] -> newTransition q0 q1 Nothing fa - [t@(Tok _)] -> newTransition q0 q1 (Just t) fa - [c@(Cat a)] | not (a `Set.member` mrCats mr) -> newTransition q0 q1 (Just c) fa - [Cat a] -> - case mrRec mr of - NotR -> -- the set is a non-recursive (always singleton) set of categories - -- so the set of category rules is the set of rules for the whole set - make_fas [(q0, b, q1) | CFRule _ b _ <- mrNonRecRules mr] fa - RightR -> -- the set is right-recursive or cyclic - let new = [(getState c, xs, q1) | CFRule c xs _ <- mrNonRecRules mr] - ++ [(getState c, xs, getState d) | CFRule c ss _ <- mrRecRules mr, - let (xs,Cat d) = (init ss,last ss)] - in make_fas new $ newTransition q0 (getState a) Nothing fa' - LeftR -> -- the set is left-recursive - let new = [(q0, xs, getState c) | CFRule c xs _ <- mrNonRecRules mr] - ++ [(getState d, xs, getState c) | CFRule c (Cat d:xs) _ <- mrRecRules mr] - in make_fas new $ newTransition (getState a) q1 Nothing fa' - where - (fa',stateMap) = addStatesForCats (mrCats mr) fa - getState x = Map.findWithDefault - (error $ "CFGToFiniteState: No state for " ++ x) - x stateMap - (x:beta) -> let (fa',q) = newState () fa - in make_fas [(q0,[x],q),(q,beta,q1)] fa' - where - make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa1 mr s1 xs s2 f') fa xs - -mutRecSets :: CFRules -> [Set Cat_] -> MutRecSets -mutRecSets g = Map.fromList . concatMap mkMutRecSet - where - mkMutRecSet cs = [ (c,ms) | c <- csl ] - where csl = Set.toList cs - rs = catSetRules g cs - (nrs,rrs) = partition (ruleIsNonRecursive cs) rs - ms = MutRecSet { - mrCats = cs, - mrNonRecRules = nrs, - mrRecRules = rrs, - mrRec = rec - } - rec | null rrs = NotR - | all (isRightLinear cs) rrs = RightR - | otherwise = LeftR - --- --- * Utilities --- - --- | Add a state for the given NFA for each of the categories --- in the given set. Returns a map of categories to their --- corresponding states. -addStatesForCats :: Set Cat_ -> NFA t -> (NFA t, Map Cat_ State) -addStatesForCats cs fa = (fa', m) - where (fa', ns) = newStates (replicate (Set.size cs) ()) fa - m = Map.fromList (zip (Set.toList cs) (map fst ns)) diff --git a/src-3.0/GF/Speech/FiniteState.hs b/src-3.0/GF/Speech/FiniteState.hs deleted file mode 100644 index 35274e3c4..000000000 --- a/src-3.0/GF/Speech/FiniteState.hs +++ /dev/null @@ -1,329 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : FiniteState --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.16 $ --- --- A simple finite state network module. ------------------------------------------------------------------------------ -module GF.Speech.FiniteState (FA(..), State, NFA, DFA, - startState, finalStates, - states, transitions, - isInternal, - newFA, newFA_, - addFinalState, - newState, newStates, - newTransition, newTransitions, - insertTransitionWith, insertTransitionsWith, - mapStates, mapTransitions, - modifyTransitions, - nonLoopTransitionsTo, nonLoopTransitionsFrom, - loops, - removeState, - oneFinalState, - insertNFA, - onGraph, - moveLabelsToNodes, removeTrivialEmptyNodes, - minimize, - dfa2nfa, - unusedNames, renameStates, - prFAGraphviz, faToGraphviz) where - -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import GF.Data.Utilities -import GF.Speech.Graph -import qualified GF.Visualization.Graphviz as Dot - -type State = Int - --- | Type parameters: node id type, state label type, edge label type --- Data constructor arguments: nodes and edges, start state, final states -data FA n a b = FA !(Graph n a b) !n ![n] - -type NFA a = FA State () (Maybe a) - -type DFA a = FA State () a - - -startState :: FA n a b -> n -startState (FA _ s _) = s - -finalStates :: FA n a b -> [n] -finalStates (FA _ _ ss) = ss - -states :: FA n a b -> [(n,a)] -states (FA g _ _) = nodes g - -transitions :: FA n a b -> [(n,n,b)] -transitions (FA g _ _) = edges g - -newFA :: Enum n => a -- ^ Start node label - -> FA n a b -newFA l = FA g s [] - where (g,s) = newNode l (newGraph [toEnum 0..]) - --- | Create a new finite automaton with an initial and a final state. -newFA_ :: Enum n => (FA n () b, n, n) -newFA_ = (fa'', s, f) - where fa = newFA () - s = startState fa - (fa',f) = newState () fa - fa'' = addFinalState f fa' - -addFinalState :: n -> FA n a b -> FA n a b -addFinalState f (FA g s ss) = FA g s (f:ss) - -newState :: a -> FA n a b -> (FA n a b, n) -newState x (FA g s ss) = (FA g' s ss, n) - where (g',n) = newNode x g - -newStates :: [a] -> FA n a b -> (FA n a b, [(n,a)]) -newStates xs (FA g s ss) = (FA g' s ss, ns) - where (g',ns) = newNodes xs g - -newTransition :: n -> n -> b -> FA n a b -> FA n a b -newTransition f t l = onGraph (newEdge (f,t,l)) - -newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b -newTransitions es = onGraph (newEdges es) - -insertTransitionWith :: Eq n => - (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b -insertTransitionWith f t = onGraph (insertEdgeWith f t) - -insertTransitionsWith :: Eq n => - (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b -insertTransitionsWith f ts fa = - foldl' (flip (insertTransitionWith f)) fa ts - -mapStates :: (a -> c) -> FA n a b -> FA n c b -mapStates f = onGraph (nmap f) - -mapTransitions :: (b -> c) -> FA n a b -> FA n a c -mapTransitions f = onGraph (emap f) - -modifyTransitions :: ([(n,n,b)] -> [(n,n,b)]) -> FA n a b -> FA n a b -modifyTransitions f = onGraph (\ (Graph r ns es) -> Graph r ns (f es)) - -removeState :: Ord n => n -> FA n a b -> FA n a b -removeState n = onGraph (removeNode n) - -minimize :: Ord a => NFA a -> DFA a -minimize = determinize . reverseNFA . dfa2nfa . determinize . reverseNFA - -unusedNames :: FA n a b -> [n] -unusedNames (FA (Graph names _ _) _ _) = names - --- | Gets all incoming transitions to a given state, excluding --- transtions from the state itself. -nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsTo s fa = - [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s] - -nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsFrom s fa = - [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s] - -loops :: Eq n => n -> FA n a b -> [b] -loops s fa = [l | (f,t,l) <- transitions fa, f == s && t == s] - --- | Give new names to all nodes. -renameStates :: Ord x => [y] -- ^ Infinite supply of new names - -> FA x a b - -> FA y a b -renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs' - where (ns,rest) = splitAt (length (nodes g)) supply - newNodes = Map.fromList (zip (map fst (nodes g)) ns) - newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes - s' = newName s - fs' = map newName fs - --- | Insert an NFA into another -insertNFA :: NFA a -- ^ NFA to insert into - -> (State, State) -- ^ States to insert between - -> NFA a -- ^ NFA to insert. - -> NFA a -insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) - = FA (newEdges es g') s1 fs1 - where - es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2] - (g',ren) = mergeGraphs g1 g2 - -onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d -onGraph f (FA g s ss) = FA (f g) s ss - - --- | Make the finite automaton have a single final state --- by adding a new final state and adding an edge --- from the old final states to the new state. -oneFinalState :: a -- ^ Label to give the new node - -> b -- ^ Label to give the new edges - -> FA n a b -- ^ The old network - -> FA n a b -- ^ The new network -oneFinalState nl el fa = - let (FA g s fs,nf) = newState nl fa - es = [ (f,nf,el) | f <- fs ] - in FA (newEdges es g) s [nf] - --- | Transform a standard finite automaton with labelled edges --- to one where the labels are on the nodes instead. This can add --- up to one extra node per edge. -moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) () -moveLabelsToNodes = onGraph f - where f g@(Graph c _ _) = Graph c' ns (concat ess) - where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] - (c',is') = mapAccumL fixIncoming c is - (ns,ess) = unzip (concat is') - - --- | Remove empty nodes which are not start or final, and have --- exactly one outgoing edge or exactly one incoming edge. -removeTrivialEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () -removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes - --- | Move edges to empty nodes to point to the next node(s). --- This is not done if the pointed-to node is a final node. -skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () -skipSimpleEmptyNodes fa = onGraph og fa - where - og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es') - where - es' = concatMap changeEdge es - info = nodeInfo g - changeEdge e@(f,t,()) - | isNothing (getNodeLabel info t) - -- && (i * o <= i + o) - && not (isFinal fa t) - = [ (f,t',()) | (_,t',()) <- getOutgoing info t] - | otherwise = [e] --- where i = inDegree info t --- o = outDegree info t - -isInternal :: Eq n => FA n a b -> n -> Bool -isInternal (FA _ start final) n = n /= start && n `notElem` final - -isFinal :: Eq n => FA n a b -> n -> Bool -isFinal (FA _ _ final) n = n `elem` final - --- | Remove all internal nodes with no incoming edges --- or no outgoing edges. -pruneUnusable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) () -pruneUnusable fa = onGraph f fa - where - f g = if Set.null rns then g else f (removeNodes rns g) - where info = nodeInfo g - rns = Set.fromList [ n | (n,_) <- nodes g, - isInternal fa n, - inDegree info n == 0 - || outDegree info n == 0] - -fixIncoming :: (Ord n, Eq a) => [n] - -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges - -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their - -- incoming edges. -fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) - where ls = nub $ map edgeLabel es - (cs',cs'') = splitAt (length ls) cs - newNodes = zip cs' ls - es' = [ (x,n,()) | x <- map fst newNodes ] - -- separate cyclic and non-cyclic edges - (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es - -- keep all incoming non-cyclic edges with the right label - to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] - -- for each cyclic edge with the right label, - -- add an edge from each of the new nodes (including this one) - ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] - newContexts = [ (v, to v) | v <- newNodes ] - -alphabet :: Eq b => Graph n a (Maybe b) -> [b] -alphabet = nub . catMaybes . map edgeLabel . edges - -determinize :: Ord a => NFA a -> DFA a -determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.empty - (ns',es') = (Set.toList ns, Set.toList es) - final = filter isDFAFinal ns' - fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final - in renameStates [0..] fa - where info = nodeInfo g --- reach = nodesReachable out - start = closure info $ Set.singleton s - isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n)) - h currentStates oldStates es - | Set.null currentStates = (oldStates,es) - | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' - where - allOldStates = oldStates `Set.union` currentStates - (newStates,es') = new (Set.toList currentStates) Set.empty es - uniqueNewStates = newStates Set.\\ allOldStates - -- Get the sets of states reachable from the given states - -- by consuming one symbol, and the associated edges. - new [] rs es = (rs,es) - new (n:ns) rs es = new ns rs' es' - where cs = reachable info n --reachable reach n - rs' = rs `Set.union` Set.fromList (map snd cs) - es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs] - - --- | Get all the nodes reachable from a list of nodes by only empty edges. -closure :: Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n -closure info x = closure_ x x - where closure_ acc check | Set.null check = acc - | otherwise = closure_ acc' check' - where - reach = Set.fromList [y | x <- Set.toList check, - (_,y,Nothing) <- getOutgoing info x] - acc' = acc `Set.union` reach - check' = reach Set.\\ acc - --- | Get a map of labels to sets of all nodes reachable --- from a the set of nodes by one edge with the given --- label and then any number of empty edges. -reachable :: (Ord n,Ord b) => NodeInfo n a (Maybe b) -> Set n -> [(b,Set n)] -reachable info ns = Map.toList $ Map.map (closure info . Set.fromList) $ reachable1 info ns -reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing info n] - -reverseNFA :: NFA a -> NFA a -reverseNFA (FA g s fs) = FA g''' s' [s] - where g' = reverseGraph g - (g'',s') = newNode () g' - g''' = newEdges [(s',f,Nothing) | f <- fs] g'' - -dfa2nfa :: DFA a -> NFA a -dfa2nfa = mapTransitions Just - --- --- * Visualization --- - -prFAGraphviz :: (Eq n,Show n) => FA n String String -> String -prFAGraphviz = Dot.prGraphviz . faToGraphviz - -prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String -prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show - -faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph -faToGraphviz (FA (Graph _ ns es) s f) - = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) [] - where mkNode (n,l) = Dot.Node (show n) attrs - where attrs = [("label",l)] - ++ if n == s then [("shape","box")] else [] - ++ if n `elem` f then [("style","bold")] else [] - mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] - --- --- * Utilities --- - -lookups :: Ord k => [k] -> Map k a -> [a] -lookups xs m = mapMaybe (flip Map.lookup m) xs diff --git a/src-3.0/GF/Speech/GrammarToVoiceXML.hs b/src-3.0/GF/Speech/GrammarToVoiceXML.hs deleted file mode 100644 index ad7f25d1c..000000000 --- a/src-3.0/GF/Speech/GrammarToVoiceXML.hs +++ /dev/null @@ -1,285 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToVoiceXML --- Maintainer : Bjorn Bringert --- Stability : (stable) --- Portability : (portable) --- --- Create VoiceXML dialogue system from a GF grammar. ------------------------------------------------------------------------------ - -module GF.Speech.GrammarToVoiceXML (grammar2vxml) where - -import GF.Canon.CanonToGFCC (canon2gfcc) -import qualified GF.GFCC.CId as C -import GF.GFCC.DataGFCC (GFCC(..), Abstr(..)) -import GF.GFCC.Macros -import qualified GF.Canon.GFC as GFC -import GF.Canon.AbsGFC (Term) -import GF.Canon.PrintGFC (printTree) -import GF.Canon.CMacros (noMark, strsFromTerm) -import GF.Canon.Unlex (formatAsText) -import GF.Data.Utilities -import GF.CF.CFIdent (cfCat2Ident) -import GF.Compile.ShellState (StateGrammar,stateGrammarST,cncId,grammar, - startCatStateOpts,stateOptions) -import GF.Data.Str (sstrV) -import GF.Grammar.Macros hiding (assign,strsFromTerm) -import GF.Grammar.Grammar (Fun) -import GF.Grammar.Values (Tree) -import GF.Infra.Option (Options, addOptions, getOptVal, speechLanguage) -import GF.UseGrammar.GetTree (string2treeErr) -import GF.UseGrammar.Linear (linTree2strings) - -import GF.Infra.Ident -import GF.Infra.Option (noOptions) -import GF.Infra.Modules -import GF.Data.Operations - -import GF.Data.XML - -import Control.Monad (liftM) -import Data.List (isPrefixOf, find, intersperse) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) - -import Debug.Trace - --- | the main function -grammar2vxml :: Options -> StateGrammar -> String -grammar2vxml opt s = showsXMLDoc (skel2vxml name language startcat gr' qs) "" - where (_, gr') = vSkeleton (stateGrammarST s) - name = prIdent (cncId s) - qs = catQuestions s (map fst gr') - opts = addOptions opt (stateOptions s) - language = fmap (replace '_' '-') $ getOptVal opts speechLanguage - startcat = C.CId $ prIdent $ cfCat2Ident $ startCatStateOpts opts s - --- --- * VSkeleton: a simple description of the abstract syntax. --- - -type VSkeleton = [(VIdent, [(VIdent, [VIdent])])] -type VIdent = C.CId - -prid :: VIdent -> String -prid (C.CId x) = x - -vSkeleton :: GFC.CanonGrammar -> (VIdent,VSkeleton) -vSkeleton = gfccSkeleton . canon2gfcc noOptions - -gfccSkeleton :: GFCC -> (VIdent,VSkeleton) -gfccSkeleton gfcc = (absname gfcc, ts) - where a = abstract gfcc - ts = [(c,[(f,ft f) | f <- fs]) | (c,fs) <- Map.toList (catfuns a)] - ft f = case lookMap (error $ prid f) f (funs a) of - (ty,_) -> fst $ GF.GFCC.Macros.catSkeleton ty - --- --- * Questions to ask --- - -type CatQuestions = [(VIdent,String)] - -catQuestions :: StateGrammar -> [VIdent] -> CatQuestions -catQuestions gr cats = [(c,catQuestion gr c) | c <- cats] - -catQuestion :: StateGrammar -> VIdent -> String -catQuestion gr cat = err errHandler id (getPrintname gr cat >>= term2string) - where -- FIXME: use some better warning facility - errHandler e = trace ("GrammarToVoiceXML: " ++ e) ("quest_"++prid cat) - term2string = liftM sstrV . strsFromTerm - -getPrintname :: StateGrammar -> VIdent -> Err Term -getPrintname gr cat = - do m <- lookupModMod (grammar gr) (cncId gr) - i <- lookupInfo m (IC (prid cat)) - case i of - GFC.CncCat _ _ p -> return p - _ -> fail $ "getPrintname " ++ prid cat - ++ ": Expected CncCat, got " ++ show i - - -{- -lin :: StateGrammar -> String -> Err String -lin gr fun = do - tree <- string2treeErr gr fun - let ls = map unt $ linTree2strings noMark g c tree - case ls of - [] -> fail $ "No linearization of " ++ fun - l:_ -> return l - where c = cncId gr - g = stateGrammarST gr - unt = formatAsText --} - -getCatQuestion :: VIdent -> CatQuestions -> String -getCatQuestion c qs = - fromMaybe (error "No question for category " ++ prid c) (lookup c qs) - --- --- * Generate VoiceXML --- - -skel2vxml :: String -> Maybe String -> VIdent -> VSkeleton -> CatQuestions -> XML -skel2vxml name language start skel qs = - vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel) - where - gr = grammarURI name - startForm = Tag "form" [] [subdialog "sub" [("src", "#"++catFormId start)] - [param "old" "{ name : '?' }"]] - -grammarURI :: String -> String -grammarURI name = name ++ ".grxml" - - -catForms :: String -> CatQuestions -> VIdent -> [(VIdent, [VIdent])] -> [XML] -catForms gr qs cat fs = - comments [prid cat ++ " category."] - ++ [cat2form gr qs cat fs] - -cat2form :: String -> CatQuestions -> VIdent -> [(VIdent, [VIdent])] -> XML -cat2form gr qs cat fs = - form (catFormId cat) $ - [var "old" Nothing, - blockCond "old.name != '?'" [assign "term" "old"], - field "term" [] - [promptString (getCatQuestion cat qs), - vxmlGrammar (gr++"#"++catFormId cat) - ] - ] - ++ concatMap (uncurry (fun2sub gr cat)) fs - ++ [block [return_ ["term"]{-]-}]] - -fun2sub :: String -> VIdent -> VIdent -> [VIdent] -> [XML] -fun2sub gr cat fun args = - comments [prid fun ++ " : (" - ++ concat (intersperse ", " (map prid args)) - ++ ") " ++ prid cat] ++ ss - where - ss = zipWith mkSub [0..] args - mkSub n t = subdialog s [("src","#"++catFormId t), - ("cond","term.name == "++string (prid fun))] - [param "old" v, - filled [] [assign v (s++".term")]] - where s = prid fun ++ "_" ++ show n - v = "term.args["++show n++"]" - -catFormId :: VIdent -> String -catFormId c = prid c ++ "_cat" - - --- --- * VoiceXML stuff --- - -vxml :: Maybe String -> [XML] -> XML -vxml ml = Tag "vxml" $ [("version","2.0"), - ("xmlns","http://www.w3.org/2001/vxml")] - ++ maybe [] (\l -> [("xml:lang", l)]) ml - -form :: String -> [XML] -> XML -form id xs = Tag "form" [("id", id)] xs - -field :: String -> [(String,String)] -> [XML] -> XML -field name attrs = Tag "field" ([("name",name)]++attrs) - -subdialog :: String -> [(String,String)] -> [XML] -> XML -subdialog name attrs = Tag "subdialog" ([("name",name)]++attrs) - -filled :: [(String,String)] -> [XML] -> XML -filled = Tag "filled" - -vxmlGrammar :: String -> XML -vxmlGrammar uri = ETag "grammar" [("src",uri)] - -prompt :: [XML] -> XML -prompt = Tag "prompt" [] - -promptString :: String -> XML -promptString p = prompt [Data p] - -reprompt :: XML -reprompt = ETag "reprompt" [] - -assign :: String -> String -> XML -assign n e = ETag "assign" [("name",n),("expr",e)] - -value :: String -> XML -value expr = ETag "value" [("expr",expr)] - -if_ :: String -> [XML] -> XML -if_ c b = if_else c b [] - -if_else :: String -> [XML] -> [XML] -> XML -if_else c t f = cond [(c,t)] f - -cond :: [(String,[XML])] -> [XML] -> XML -cond ((c,b):rest) els = Tag "if" [("cond",c)] (b ++ es) - where es = [Tag "elseif" [("cond",c')] b' | (c',b') <- rest] - ++ if null els then [] else (Tag "else" [] []:els) - -goto_item :: String -> XML -goto_item nextitem = ETag "goto" [("nextitem",nextitem)] - -return_ :: [String] -> XML -return_ names = ETag "return" [("namelist", unwords names)] - -block :: [XML] -> XML -block = Tag "block" [] - -blockCond :: String -> [XML] -> XML -blockCond cond = Tag "block" [("cond", cond)] - -throw :: String -> String -> XML -throw event msg = Tag "throw" [("event",event),("message",msg)] [] - -nomatch :: [XML] -> XML -nomatch = Tag "nomatch" [] - -help :: [XML] -> XML -help = Tag "help" [] - -param :: String -> String -> XML -param name expr = ETag "param" [("name",name),("expr",expr)] - -var :: String -> Maybe String -> XML -var name expr = ETag "var" ([("name",name)]++e) - where e = maybe [] ((:[]) . (,) "expr") expr - -script :: String -> XML -script s = Tag "script" [] [CData s] - -scriptURI :: String -> XML -scriptURI uri = Tag "script" [("uri", uri)] [] - --- --- * ECMAScript stuff --- - -string :: String -> String -string s = "'" ++ concatMap esc s ++ "'" - where esc '\'' = "\\'" - esc c = [c] - -{- --- --- * List stuff --- - -isListCat :: (VIdent, [(VIdent, [VIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` prIdent cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = drop 4 (prIdent cat) - fs = map (prIdent . fst) rules - -isBaseFun :: VIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` prIdent f - -isConsFun :: VIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` prIdent f - -baseSize :: (VIdent, [(VIdent, [VIdent])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (isBaseFun . fst) rules --} diff --git a/src-3.0/GF/Speech/Graph.hs b/src-3.0/GF/Speech/Graph.hs deleted file mode 100644 index 1a0ebe0c0..000000000 --- a/src-3.0/GF/Speech/Graph.hs +++ /dev/null @@ -1,178 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Graph --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- A simple graph module. ------------------------------------------------------------------------------ -module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo - , newGraph, nodes, edges - , nmap, emap, newNode, newNodes, newEdge, newEdges - , insertEdgeWith - , removeNode, removeNodes - , nodeInfo - , getIncoming, getOutgoing, getNodeLabel - , inDegree, outDegree - , nodeLabel - , edgeFrom, edgeTo, edgeLabel - , reverseGraph, mergeGraphs, renameNodes - ) where - -import GF.Data.Utilities - -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -data Graph n a b = Graph [n] ![Node n a] ![Edge n b] - deriving (Eq,Show) - -type Node n a = (n,a) -type Edge n b = (n,n,b) - -type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b]) - --- | Create a new empty graph. -newGraph :: [n] -> Graph n a b -newGraph ns = Graph ns [] [] - --- | Get all the nodes in the graph. -nodes :: Graph n a b -> [Node n a] -nodes (Graph _ ns _) = ns - --- | Get all the edges in the graph. -edges :: Graph n a b -> [Edge n b] -edges (Graph _ _ es) = es - --- | Map a function over the node labels. -nmap :: (a -> c) -> Graph n a b -> Graph n c b -nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es - --- | Map a function over the edge labels. -emap :: (b -> c) -> Graph n a b -> Graph n a c -emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es] - --- | Add a node to the graph. -newNode :: a -- ^ Node label - -> Graph n a b - -> (Graph n a b,n) -- ^ Node graph and name of new node -newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c) - -newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a]) -newNodes ls g = (g', zip ns ls) - where (g',ns) = mapAccumL (flip newNode) g ls --- lazy version: ---newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns') --- where (xs,cs') = splitAt (length ls) cs --- ns' = zip xs ls - -newEdge :: Edge n b -> Graph n a b -> Graph n a b -newEdge e (Graph c ns es) = Graph c ns (e:es) - -newEdges :: [Edge n b] -> Graph n a b -> Graph n a b -newEdges es g = foldl' (flip newEdge) g es --- lazy version: --- newEdges es' (Graph c ns es) = Graph c ns (es'++es) - -insertEdgeWith :: Eq n => - (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b -insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es) - where h [] = [e] - h (e'@(x',y',l'):es') | x' == x && y' == y = (x',y', f l l'):es' - | otherwise = e':h es' - --- | Remove a node and all edges to and from that node. -removeNode :: Ord n => n -> Graph n a b -> Graph n a b -removeNode n = removeNodes (Set.singleton n) - --- | Remove a set of nodes and all edges to and from those nodes. -removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b -removeNodes xs (Graph c ns es) = Graph c ns' es' - where - keepNode n = not (Set.member n xs) - ns' = [ x | x@(n,_) <- ns, keepNode n ] - es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ] - --- | Get a map of node names to info about each node. -nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b -nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ] - where - inc = groupEdgesBy edgeTo g - out = groupEdgesBy edgeFrom g - fn m n = fromMaybe [] (Map.lookup n m) - -groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by - -> Graph n a b -> Map n [Edge n b] -groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g] - -lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b]) -lookupNode i n = fromJust $ Map.lookup n i - -getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b] -getIncoming i n = let (_,inc,_) = lookupNode i n in inc - -getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b] -getOutgoing i n = let (_,_,out) = lookupNode i n in out - -inDegree :: Ord n => NodeInfo n a b -> n -> Int -inDegree i n = length $ getIncoming i n - -outDegree :: Ord n => NodeInfo n a b -> n -> Int -outDegree i n = length $ getOutgoing i n - -getNodeLabel :: Ord n => NodeInfo n a b -> n -> a -getNodeLabel i n = let (l,_,_) = lookupNode i n in l - -nodeLabel :: Node n a -> a -nodeLabel = snd - -edgeFrom :: Edge n b -> n -edgeFrom (f,_,_) = f - -edgeTo :: Edge n b -> n -edgeTo (_,t,_) = t - -edgeLabel :: Edge n b -> b -edgeLabel (_,_,l) = l - -reverseGraph :: Graph n a b -> Graph n a b -reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ] - --- | Add the nodes from the second graph to the first graph. --- The nodes in the second graph will be renamed using the name --- supply in the first graph. --- This function is more efficient when the second graph --- is smaller than the first. -mergeGraphs :: Ord m => Graph n a b -> Graph m a b - -> (Graph n a b, m -> n) -- ^ The new graph and a function translating - -- the old names of nodes in the second graph - -- to names in the new graph. -mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName) - where - (xs,c') = splitAt (length (nodes g2)) c - newNames = Map.fromList (zip (map fst (nodes g2)) xs) - newName n = fromJust $ Map.lookup n newNames - Graph _ ns2 es2 = renameNodes newName undefined g2 - --- | Rename the nodes in the graph. -renameNodes :: (n -> m) -- ^ renaming function - -> [m] -- ^ infinite supply of fresh node names, to - -- use when adding nodes in the future. - -> Graph n a b -> Graph m a b -renameNodes newName c (Graph _ ns es) = Graph c ns' es' - where ns' = map' (\ (n,x) -> (newName n,x)) ns - es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es - --- | A strict 'map' -map' :: (a -> b) -> [a] -> [b] -map' _ [] = [] -map' f (x:xs) = ((:) $! f x) $! map' f xs diff --git a/src-3.0/GF/Speech/PrFA.hs b/src-3.0/GF/Speech/PrFA.hs deleted file mode 100644 index 2856039ec..000000000 --- a/src-3.0/GF/Speech/PrFA.hs +++ /dev/null @@ -1,56 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrSLF --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- This module prints finite automata and regular grammars --- for a context-free grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar ------------------------------------------------------------------------------ - -module GF.Speech.PrFA (faGraphvizPrinter,regularPrinter,faCPrinter) where - -import GF.Data.Utilities -import GF.Conversion.Types -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..),symbol) -import GF.Infra.Ident -import GF.Infra.Option (Options) -import GF.Infra.Print -import GF.Speech.CFGToFiniteState -import GF.Speech.FiniteState -import GF.Speech.TransformCFG -import GF.Compile.ShellState (StateGrammar) - -import Data.Char (toUpper,toLower) -import Data.List -import Data.Maybe (fromMaybe) - - - -faGraphvizPrinter :: Options -> StateGrammar -> String -faGraphvizPrinter opts s = - prFAGraphviz $ mapStates (const "") $ cfgToFA opts s - --- | Convert the grammar to a regular grammar and print it in BNF -regularPrinter :: Options -> StateGrammar -> String -regularPrinter opts s = prCFRules $ makeSimpleRegular opts s - where - prCFRules :: CFRules -> String - prCFRules g = unlines [ c ++ " ::= " ++ join " | " (map (showRhs . ruleRhs) rs) | (c,rs) <- allRulesGrouped g] - join g = concat . intersperse g - showRhs = unwords . map (symbol id show) - -faCPrinter :: Options -> StateGrammar -> String -faCPrinter opts s = fa2c $ cfgToFA opts s - -fa2c :: DFA String -> String -fa2c fa = undefined diff --git a/src-3.0/GF/Speech/PrGSL.hs b/src-3.0/GF/Speech/PrGSL.hs deleted file mode 100644 index 248991380..000000000 --- a/src-3.0/GF/Speech/PrGSL.hs +++ /dev/null @@ -1,113 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrGSL --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.22 $ --- --- This module prints a CFG as a Nuance GSL 2.0 grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar ------------------------------------------------------------------------------ - -module GF.Speech.PrGSL (gslPrinter) where - -import GF.Data.Utilities -import GF.Speech.SRG -import GF.Speech.RegExp -import GF.Infra.Ident - -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..)) -import GF.Conversion.Types -import GF.Infra.Print -import GF.Infra.Option -import GF.Probabilistic.Probabilistic (Probs) -import GF.Compile.ShellState (StateGrammar) - -import Data.Char (toUpper,toLower) -import Data.List (partition) -import Text.PrettyPrint.HughesPJ - -width :: Int -width = 75 - -gslPrinter :: Options -> StateGrammar -> String -gslPrinter opts s = renderStyle st $ prGSL $ makeSimpleSRG opts s - where st = style { lineLength = width } - -prGSL :: SRG -> Doc -prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) - = header $++$ mainCat $++$ foldr ($++$) empty (map prRule rs) - where - header = text ";GSL2.0" $$ - comment ("Nuance speech recognition grammar for " ++ name) $$ - comment ("Generated by GF") - mainCat = comment ("Start category: " ++ origStart) $$ - text ".MAIN" <+> prCat start - prRule (SRGRule cat origCat rhs) = - comment (prt origCat) $$ - prCat cat <+> union (map prAlt rhs) - -- FIXME: use the probability - prAlt (SRGAlt mp _ rhs) = prItem rhs - - -prItem :: SRGItem -> Doc -prItem = f - where - f (REUnion xs) = (if null es then empty else text "?") <> union (map f nes) - where (es,nes) = partition isEpsilon xs - f (REConcat [x]) = f x - f (REConcat xs) = text "(" <> fsep (map f xs) <> text ")" - f (RERepeat x) = text "*" <> f x - f (RESymbol s) = prSymbol s - -union :: [Doc] -> Doc -union [x] = x -union xs = text "[" <> fsep xs <> text "]" - -prSymbol :: Symbol SRGNT Token -> Doc -prSymbol (Cat (c,_)) = prCat c -prSymbol (Tok t) = doubleQuotes (showToken t) - --- GSL requires an upper case letter in category names -prCat :: SRGCat -> Doc -prCat c = text (firstToUpper c) - - -firstToUpper :: String -> String -firstToUpper [] = [] -firstToUpper (x:xs) = toUpper x : xs - -{- -rmPunctCFG :: CGrammar -> CGrammar -rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g] - -keepSymbol :: Symbol c Token -> Bool -keepSymbol (Tok t) = not (all isPunct (prt t)) -keepSymbol _ = True --} - --- Nuance does not like upper case characters in tokens -showToken :: Token -> Doc -showToken t = text (map toLower (prt t)) - -isPunct :: Char -> Bool -isPunct c = c `elem` "-_.:;.,?!()[]{}" - -comment :: String -> Doc -comment s = text ";" <+> text s - - --- Pretty-printing utilities - -emptyLine :: Doc -emptyLine = text "" - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $$ emptyLine $$ y diff --git a/src-3.0/GF/Speech/PrJSGF.hs b/src-3.0/GF/Speech/PrJSGF.hs deleted file mode 100644 index 037a4f4e2..000000000 --- a/src-3.0/GF/Speech/PrJSGF.hs +++ /dev/null @@ -1,145 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrJSGF --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.16 $ --- --- This module prints a CFG as a JSGF grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar --- --- FIXME: convert to UTF-8 ------------------------------------------------------------------------------ - -module GF.Speech.PrJSGF (jsgfPrinter) where - -import GF.Conversion.Types -import GF.Data.Utilities -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), filterCats) -import GF.Infra.Ident -import GF.Infra.Print -import GF.Infra.Option -import GF.Probabilistic.Probabilistic (Probs) -import GF.Speech.SISR -import GF.Speech.SRG -import GF.Speech.RegExp -import GF.Compile.ShellState (StateGrammar) - -import Data.Char -import Data.List -import Data.Maybe -import Text.PrettyPrint.HughesPJ -import Debug.Trace - -width :: Int -width = 75 - -jsgfPrinter :: Maybe SISRFormat - -> Options - -> StateGrammar -> String -jsgfPrinter sisr opts s = renderStyle st $ prJSGF sisr $ makeSimpleSRG opts s - where st = style { lineLength = width } - -prJSGF :: Maybe SISRFormat -> SRG -> Doc -prJSGF sisr srg@(SRG{grammarName=name,grammarLanguage=ml, - startCat=start,origStartCat=origStart,rules=rs}) - = header $++$ mainCat $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs) - where - header = text "#JSGF" <+> text "V1.0" <+> text "UTF-8" <+> lang <> char ';' $$ - comment ("JSGF speech recognition grammar for " ++ name) $$ - comment "Generated by GF" $$ - text ("grammar " ++ name ++ ";") - lang = maybe empty text ml - mainCat = comment ("Start category: " ++ origStart) $$ - case cfgCatToGFCat origStart of - Just c -> rule True "MAIN" [prCat (catFormId c)] - Nothing -> empty - prRule (SRGRule cat origCat rhs) = - comment origCat $$ - rule False cat (map prAlt rhs) --- rule False cat (map prAlt rhs) - -- FIXME: use the probability - prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag] --- prAlt (SRGAlt mp n rhs) = initTag <+> prItem sisr n rhs <+> finalTag - where initTag | isEmpty t = empty - | otherwise = text "" <+> t - where t = tag sisr (profileInitSISR n) - finalTag = tag sisr (profileFinalSISR n) - p = if isEmpty initTag && isEmpty finalTag then id else parens - - topCatRules = [rule True (catFormId tc) (map (it tc) cs) | (tc,cs) <- srgTopCats srg] - where it i c = prCat c <+> tag sisr (topCatSISR c) - -catFormId :: String -> String -catFormId = (++ "_cat") - -prCat :: SRGCat -> Doc -prCat c = char '<' <> text c <> char '>' - -prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc -prItem sisr t = f 0 - where - f _ (REUnion []) = text "" - f p (REUnion xs) - | not (null es) = brackets (f 0 (REUnion nes)) - | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) - where (es,nes) = partition isEpsilon xs - f _ (REConcat []) = text "" - f p (REConcat xs) = (if p >= 3 then parens else id) (fsep (map (f 2) xs)) - f p (RERepeat x) = f 3 x <> char '*' - f _ (RESymbol s) = prSymbol sisr t s - -{- -prItem :: Maybe SISRFormat -> CFTerm -> [Symbol SRGNT Token] -> Doc -prItem _ _ [] = text "" -prItem sisr cn ss = paren $ hsep $ map (prSymbol sisr cn) ss - where paren = if length ss == 1 then id else parens --} - -prSymbol :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> Doc -prSymbol sisr cn (Cat n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) -prSymbol _ cn (Tok t) | all isPunct (prt t) = empty -- removes punctuation - | otherwise = text (prt t) -- FIXME: quote if there is whitespace or odd chars - -tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc -tag Nothing _ = empty -tag (Just fmt) t = case t fmt of - [] -> empty - ts -> char '{' <+> (text (e $ prSISR ts)) <+> char '}' - where e [] = [] - e ('}':xs) = '\\':'}':e xs - e ('\n':xs) = ' ' : e (dropWhile isSpace xs) - e (x:xs) = x:e xs - -isPunct :: Char -> Bool -isPunct c = c `elem` "-_.;.,?!" - -comment :: String -> Doc -comment s = text "//" <+> text s - -alts :: [Doc] -> Doc -alts = fsep . prepunctuate (text "| ") - -rule :: Bool -> SRGCat -> [Doc] -> Doc -rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';' - where p = if pub then text "public" else empty - --- Pretty-printing utilities - -emptyLine :: Doc -emptyLine = text "" - -prepunctuate :: Doc -> [Doc] -> [Doc] -prepunctuate _ [] = [] -prepunctuate p (x:xs) = x : map (p <>) xs - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $$ emptyLine $$ y - diff --git a/src-3.0/GF/Speech/PrRegExp.hs b/src-3.0/GF/Speech/PrRegExp.hs deleted file mode 100644 index 55a25d69b..000000000 --- a/src-3.0/GF/Speech/PrRegExp.hs +++ /dev/null @@ -1,33 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrSLF --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- This module prints a grammar as a regular expression. ------------------------------------------------------------------------------ - -module GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter) where - -import GF.Conversion.Types -import GF.Formalism.Utilities -import GF.Infra.Ident -import GF.Infra.Option (Options) -import GF.Speech.CFGToFiniteState -import GF.Speech.RegExp -import GF.Compile.ShellState (StateGrammar) - - -regexpPrinter :: Options -> StateGrammar -> String -regexpPrinter opts s = (++"\n") $ prRE $ dfa2re $ cfgToFA opts s - -multiRegexpPrinter :: Options -> StateGrammar -> String -multiRegexpPrinter opts s = prREs $ mfa2res $ cfgToMFA opts s - -prREs :: [(String,RE (MFALabel String))] -> String -prREs res = unlines [l ++ " = " ++ prRE (mapRE showLabel re) | (l,re) <- res] - where showLabel = symbol (\l -> "<" ++ l ++ ">") id - -mfa2res :: MFA String -> [(String,RE (MFALabel String))] -mfa2res (MFA _ dfas) = [(l, minimizeRE (dfa2re dfa)) | (l,dfa) <- dfas] diff --git a/src-3.0/GF/Speech/PrSLF.hs b/src-3.0/GF/Speech/PrSLF.hs deleted file mode 100644 index 9bc025558..000000000 --- a/src-3.0/GF/Speech/PrSLF.hs +++ /dev/null @@ -1,190 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrSLF --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.12 $ --- --- This module converts a CFG to an SLF finite-state network --- for use with the ATK recognizer. The SLF format is described --- in the HTK manual, and an example for use in ATK is shown --- in the ATK manual. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar ------------------------------------------------------------------------------ - -module GF.Speech.PrSLF (slfPrinter,slfGraphvizPrinter, - slfSubPrinter,slfSubGraphvizPrinter) where - -import GF.Data.Utilities -import GF.Conversion.Types -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..),symbol,mapSymbol) -import GF.Infra.Ident -import GF.Infra.Option (Options) -import GF.Infra.Print -import GF.Speech.CFGToFiniteState -import GF.Speech.FiniteState -import GF.Speech.TransformCFG -import qualified GF.Visualization.Graphviz as Dot -import GF.Compile.ShellState (StateGrammar) - -import Control.Monad -import qualified Control.Monad.State as STM -import Data.Char (toUpper) -import Data.List -import Data.Maybe - -data SLFs = SLFs [(String,SLF)] SLF - -data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] } - -data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord, nTag :: Maybe String } - | SLFSubLat { nId :: Int, nLat :: String } - --- | An SLF word is a word, or the empty string. -type SLFWord = Maybe String - -data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int } - -type SLF_FA = FA State (Maybe (MFALabel String)) () - -mkFAs :: Options -> StateGrammar -> (SLF_FA, [(String,SLF_FA)]) -mkFAs opts s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) - where MFA start subs = {- renameSubs $ -} cfgToMFA opts s - main = let (fa,s,f) = newFA_ in newTransition s f (Cat start) fa - -slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) () -slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () - . moveLabelsToNodes . dfa2nfa - --- | Give sequential names to subnetworks. -renameSubs :: MFA String -> MFA String -renameSubs (MFA start subs) = MFA (newName start) subs' - where newNames = zip (map fst subs) ["sub"++show n | n <- [0..]] - newName s = lookup' s newNames - subs' = [(newName s,renameLabels n) | (s,n) <- subs] - renameLabels = mapTransitions (mapSymbol newName id) - --- --- * SLF graphviz printing (without sub-networks) --- - -slfGraphvizPrinter :: Options -> StateGrammar -> String -slfGraphvizPrinter opts s - = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' opts s - where - gvFA = mapStates (fromMaybe "") . mapTransitions (const "") - --- --- * SLF graphviz printing (with sub-networks) --- - -slfSubGraphvizPrinter :: Options -> StateGrammar -> String -slfSubGraphvizPrinter opts s = Dot.prGraphviz g - where (main, subs) = mkFAs opts s - g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] - ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs - m = gvSLFFA Nothing main - -gvSLFFA :: Maybe String -> SLF_FA -> STM.State [State] Dot.Graph -gvSLFFA n fa = - liftM (mkCluster n . faToGraphviz . mapStates (maybe "" mfaLabelToGv) - . mapTransitions (const "")) (rename fa) - where mfaLabelToGv = symbol ("#"++) id - mkCluster Nothing = id - mkCluster (Just x) - = Dot.setName ("cluster_"++x) . Dot.setAttr "label" x - rename fa = do - names <- STM.get - let fa' = renameStates names fa - names' = unusedNames fa' - STM.put names' - return fa' - --- --- * SLF printing (without sub-networks) --- - -slfPrinter :: Options -> StateGrammar -> String -slfPrinter opts s - = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' opts s - --- --- * SLF printing (with sub-networks) --- - --- | Make a network with subnetworks in SLF -slfSubPrinter :: Options -> StateGrammar -> String -slfSubPrinter opts s = prSLFs slfs - where - (main,subs) = mkFAs opts s - slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main) - faToSLF = automatonToSLF mfaNodeToSLFNode - -automatonToSLF :: (Int -> a -> SLFNode) -> FA State a () -> SLF -automatonToSLF mkNode fa = SLF { slfNodes = ns, slfEdges = es } - where ns = map (uncurry mkNode) (states fa) - es = zipWith (\i (f,t,()) -> mkSLFEdge i (f,t)) [0..] (transitions fa) - -mfaNodeToSLFNode :: Int -> Maybe (MFALabel String) -> SLFNode -mfaNodeToSLFNode i l = case l of - Nothing -> mkSLFNode i Nothing - Just (Tok x) -> mkSLFNode i (Just x) - Just (Cat s) -> mkSLFSubLat i s - -mkSLFNode :: Int -> Maybe String -> SLFNode -mkSLFNode i Nothing = SLFNode { nId = i, nWord = Nothing, nTag = Nothing } -mkSLFNode i (Just w) - | isNonWord w = SLFNode { nId = i, - nWord = Nothing, - nTag = Just w } - | otherwise = SLFNode { nId = i, - nWord = Just (map toUpper w), - nTag = Just w } - -mkSLFSubLat :: Int -> String -> SLFNode -mkSLFSubLat i sub = SLFSubLat { nId = i, nLat = sub } - -mkSLFEdge :: Int -> (Int,Int) -> SLFEdge -mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t } - -prSLFs :: SLFs -> String -prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main]) "" - where prSub (n,s) = showString "SUBLAT=" . shows n - . nl . prOneSLF s . showString "." . nl - -prSLF :: SLF -> String -prSLF slf = prOneSLF slf "" - -prOneSLF :: SLF -> ShowS -prOneSLF (SLF { slfNodes = ns, slfEdges = es}) - = header . unlinesS (map prNode ns) . nl . unlinesS (map prEdge es) . nl - where - header = prFields [("N",show (length ns)),("L", show (length es))] . nl - prNode (SLFNode { nId = i, nWord = w, nTag = t }) - = prFields $ [("I",show i),("W",showWord w)] - ++ maybe [] (\t -> [("s",t)]) t - prNode (SLFSubLat { nId = i, nLat = l }) - = prFields [("I",show i),("L",show l)] - prEdge e = prFields [("J",show (eId e)),("S",show (eStart e)),("E",show (eEnd e))] - --- | Check if a word should not correspond to a word in the SLF file. -isNonWord :: String -> Bool -isNonWord = any isPunct - -isPunct :: Char -> Bool -isPunct c = c `elem` "-_.;.,?!()[]{}" - -showWord :: SLFWord -> String -showWord Nothing = "!NULL" -showWord (Just w) | null w = "!NULL" - | otherwise = w - -prFields :: [(String,String)] -> ShowS -prFields fs = unwordsS [ showString l . showChar '=' . showString v | (l,v) <- fs ] diff --git a/src-3.0/GF/Speech/PrSRGS.hs b/src-3.0/GF/Speech/PrSRGS.hs deleted file mode 100644 index d8ae07867..000000000 --- a/src-3.0/GF/Speech/PrSRGS.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrSRGS --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- This module prints a CFG as an SRGS XML grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar ------------------------------------------------------------------------------ - -module GF.Speech.PrSRGS (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where - -import GF.Data.Utilities -import GF.Data.XML -import GF.Speech.RegExp -import GF.Speech.SISR as SISR -import GF.Speech.SRG -import GF.Infra.Ident -import GF.Today - -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), forestName, filterCats) -import GF.Conversion.Types -import GF.Infra.Print -import GF.Infra.Option -import GF.Probabilistic.Probabilistic (Probs) -import GF.Compile.ShellState (StateGrammar) - -import Data.Char (toUpper,toLower) -import Data.List -import Data.Maybe -import qualified Data.Map as Map -import qualified Data.Set as Set - -srgsXmlPrinter :: Maybe SISRFormat - -> Bool -- ^ Include probabilities - -> Options - -> StateGrammar -> String -srgsXmlPrinter sisr probs opts s = prSrgsXml sisr probs $ makeSimpleSRG opts s - -srgsXmlNonRecursivePrinter :: Options -> StateGrammar -> String -srgsXmlNonRecursivePrinter opts s = prSrgsXml Nothing False $ makeNonRecursiveSRG opts s - - -prSrgsXml :: Maybe SISRFormat -> Bool -> SRG -> String -prSrgsXml sisr probs srg@(SRG{grammarName=name,startCat=start, - origStartCat=origStart,grammarLanguage=l,rules=rs}) - = showXMLDoc (optimizeSRGS xmlGr) - where - Just root = cfgCatToGFCat origStart - xmlGr = grammar sisr (catFormId root) l $ - [meta "description" - ("SRGS XML speech recognition grammar for " ++ name - ++ ". " ++ "Original start category: " ++ origStart), - meta "generator" ("Grammatical Framework " ++ version)] - ++ topCatRules - ++ concatMap ruleToXML rs - ruleToXML (SRGRule cat origCat alts) = - comments ["Category " ++ origCat] ++ [rule cat (prRhs alts)] - prRhs rhss = [oneOf (map (mkProd sisr probs) rhss)] - -- externally visible rules for each of the GF categories - topCatRules = [topRule tc [oneOf (map (it tc) cs)] | (tc,cs) <- srgTopCats srg] - where it i c = Tag "item" [] ([ETag "ruleref" [("uri","#" ++ c)]] - ++ tag sisr (topCatSISR c)) - topRule i is = Tag "rule" [("id",catFormId i),("scope","public")] is - -rule :: String -> [XML] -> XML -rule i = Tag "rule" [("id",i)] - -mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML -mkProd sisr probs (SRGAlt mp n rhs) = Tag "item" w (ti ++ [x] ++ tf) - where x = mkItem sisr n rhs - w | probs = maybe [] (\p -> [("weight", show p)]) mp - | otherwise = [] - ti = tag sisr (profileInitSISR n) - tf = tag sisr (profileFinalSISR n) - -mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML -mkItem sisr cn = f - where - f (REUnion []) = ETag "ruleref" [("special","VOID")] - f (REUnion xs) - | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)] - | otherwise = oneOf (map f xs) - where (es,nes) = partition isEpsilon xs - f (REConcat []) = ETag "ruleref" [("special","NULL")] - f (REConcat xs) = Tag "item" [] (map f xs) - f (RERepeat x) = Tag "item" [("repeat","0-")] [f x] - f (RESymbol s) = symItem sisr cn s - -{- -mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML -mkProd sisr probs (SRGAlt mp n rhs) = Tag "item" w (ti ++ xs ++ tf) - where xs = mkItem sisr n rhs - w | probs = maybe [] (\p -> [("weight", show p)]) mp - | otherwise = [] - ti = [tag sisr (profileInitSISR n)] - tf = [tag sisr (profileFinalSISR n)] - - -mkItem :: Maybe SISRFormat -> CFTerm -> [Symbol SRGNT Token] -> [XML] -mkItem sisr cn ss = map (symItem sisr cn) ss --} - -symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML -symItem sisr cn (Cat n@(c,_)) = - Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n) -symItem _ _ (Tok t) = Tag "item" [] [Data (showToken t)] - -tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML] -tag Nothing _ = [] -tag (Just fmt) t = case t fmt of - [] -> [] - ts -> [Tag "tag" [] [Data (prSISR ts)]] - -catFormId :: String -> String -catFormId = (++ "_cat") - - -showToken :: Token -> String -showToken t = t - -oneOf :: [XML] -> XML -oneOf = Tag "one-of" [] - -grammar :: Maybe SISRFormat - -> String -- ^ root - -> Maybe String -- ^language - -> [XML] -> XML -grammar sisr root ml = - Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"), - ("version","1.0"), - ("mode","voice"), - ("root",root)] - ++ (if isJust sisr then [("tag-format","semantics/1.0")] else []) - ++ maybe [] (\l -> [("xml:lang", l)]) ml - -meta :: String -> String -> XML -meta n c = ETag "meta" [("name",n),("content",c)] - -optimizeSRGS :: XML -> XML -optimizeSRGS = bottomUpXML f - where f (Tag "item" [] [x@(Tag "item" _ _)]) = x - f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x - f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs - f (Tag "item" as xs) = Tag "item" as (map g xs) - where g (Tag "item" [] [x@(ETag "ruleref" _)]) = x - g x = x - f (Tag "one-of" [] [x]) = x - f x = x diff --git a/src-3.0/GF/Speech/PrSRGS_ABNF.hs b/src-3.0/GF/Speech/PrSRGS_ABNF.hs deleted file mode 100644 index abb84c5dc..000000000 --- a/src-3.0/GF/Speech/PrSRGS_ABNF.hs +++ /dev/null @@ -1,147 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrJSRGS_ABNF --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.16 $ --- --- This module prints a CFG as a JSGF grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar --- --- FIXME: convert to UTF-8 ------------------------------------------------------------------------------ - -module GF.Speech.PrSRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where - -import GF.Conversion.Types -import GF.Data.Utilities -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), filterCats) -import GF.Infra.Ident -import GF.Infra.Print -import GF.Infra.Option -import GF.Probabilistic.Probabilistic (Probs) -import GF.Speech.SISR -import GF.Speech.SRG -import GF.Speech.RegExp -import GF.Compile.ShellState (StateGrammar) -import GF.Today - -import Data.Char -import Data.List -import Data.Maybe -import Text.PrettyPrint.HughesPJ -import Debug.Trace - -width :: Int -width = 75 - -srgsAbnfPrinter :: Maybe SISRFormat - -> Bool -- ^ Include probabilities - -> Options - -> StateGrammar -> String -srgsAbnfPrinter sisr probs opts s = showDoc $ prABNF sisr probs $ makeSimpleSRG opts s - -srgsAbnfNonRecursivePrinter :: Options -> StateGrammar -> String -srgsAbnfNonRecursivePrinter opts s = showDoc $ prABNF Nothing False $ makeNonRecursiveSRG opts s - -showDoc = renderStyle (style { lineLength = width }) - -prABNF :: Maybe SISRFormat -> Bool -> SRG -> Doc -prABNF sisr probs srg@(SRG{grammarName=name,grammarLanguage=ml, - startCat=start,origStartCat=origStart,rules=rs}) - = header $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs) - where - header = text "#ABNF 1.0 UTF-8;" $$ - meta "description" - ("Speech recognition grammar for " ++ name - ++ ". " ++ "Original start category: " ++ origStart) $$ - meta "generator" ("Grammatical Framework " ++ version) $$ - language $$ tagFormat $$ mainCat - language = maybe empty (\l -> text "language" <+> text l <> char ';') ml - tagFormat | isJust sisr = text "tag-format" <+> text "" <> char ';' - | otherwise = empty - mainCat = case cfgCatToGFCat origStart of - Just c -> text "root" <+> prCat (catFormId c) <> char ';' - Nothing -> empty - prRule (SRGRule cat origCat rhs) = - comment origCat $$ - rule False cat (map prAlt rhs) - -- FIXME: use the probability - prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag] - where initTag = tag sisr (profileInitSISR n) - finalTag = tag sisr (profileFinalSISR n) - p = if isEmpty initTag && isEmpty finalTag then id else parens - - topCatRules = [rule True (catFormId tc) (map (it tc) cs) | (tc,cs) <- srgTopCats srg] - where it i c = prCat c <+> tag sisr (topCatSISR c) - -catFormId :: String -> String -catFormId = (++ "_cat") - -prCat :: SRGCat -> Doc -prCat c = char '$' <> text c - -prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc -prItem sisr t = f 0 - where - f _ (REUnion []) = text "$VOID" - f p (REUnion xs) - | not (null es) = brackets (f 0 (REUnion nes)) - | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) - where (es,nes) = partition isEpsilon xs - f _ (REConcat []) = text "$NULL" - f p (REConcat xs) = (if p >= 3 then parens else id) (fsep (map (f 2) xs)) - f p (RERepeat x) = f 3 x <> text "<0->" - f _ (RESymbol s) = prSymbol sisr t s - - -prSymbol :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> Doc -prSymbol sisr cn (Cat n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) -prSymbol _ cn (Tok t) | all isPunct (prt t) = empty -- removes punctuation - | otherwise = text (prt t) -- FIXME: quote if there is whitespace or odd chars - -tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc -tag Nothing _ = empty -tag (Just fmt) t = - case t fmt of - [] -> empty - -- grr, silly SRGS ABNF does not have an escaping mechanism - ts | '{' `elem` x || '}' `elem` x -> text "{!{" <+> text x <+> text "}!}" - | otherwise -> text "{" <+> text x <+> text "}" - where x = prSISR ts - -isPunct :: Char -> Bool -isPunct c = c `elem` "-_.;.,?!" - -comment :: String -> Doc -comment s = text "//" <+> text s - -alts :: [Doc] -> Doc -alts = fsep . prepunctuate (text "| ") - -rule :: Bool -> SRGCat -> [Doc] -> Doc -rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';' - where p = if pub then text "public" else empty - -meta :: String -> String -> Doc -meta n v = text "meta" <+> text (show n) <+> text "is" <+> text (show v) <> char ';' - --- Pretty-printing utilities - -emptyLine :: Doc -emptyLine = text "" - -prepunctuate :: Doc -> [Doc] -> [Doc] -prepunctuate _ [] = [] -prepunctuate p (x:xs) = x : map (p <>) xs - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $$ emptyLine $$ y - diff --git a/src-3.0/GF/Speech/RegExp.hs b/src-3.0/GF/Speech/RegExp.hs deleted file mode 100644 index 5ee40828e..000000000 --- a/src-3.0/GF/Speech/RegExp.hs +++ /dev/null @@ -1,143 +0,0 @@ -module GF.Speech.RegExp (RE(..), - epsilonRE, nullRE, - isEpsilon, isNull, - unionRE, concatRE, seqRE, - repeatRE, minimizeRE, - mapRE, mapRE', joinRE, - symbolsRE, - dfa2re, prRE) where - -import Data.List - -import GF.Data.Utilities -import GF.Speech.FiniteState - -data RE a = - REUnion [RE a] -- ^ REUnion [] is null - | REConcat [RE a] -- ^ REConcat [] is epsilon - | RERepeat (RE a) - | RESymbol a - deriving (Eq,Ord,Show) - - -dfa2re :: (Ord a) => DFA a -> RE a -dfa2re = finalRE . elimStates . modifyTransitions merge . addLoops - . oneFinalState () epsilonRE . mapTransitions RESymbol - where addLoops fa = newTransitions [(s,s,nullRE) | (s,_) <- states fa] fa - merge es = [(f,t,unionRE ls) - | ((f,t),ls) <- buildMultiMap [((f,t),l) | (f,t,l) <- es]] - -elimStates :: (Ord a) => DFA (RE a) -> DFA (RE a) -elimStates fa = - case [s | (s,_) <- states fa, isInternal fa s] of - [] -> fa - sE:_ -> elimStates $ insertTransitionsWith (\x y -> unionRE [x,y]) ts $ removeState sE fa - where sAs = nonLoopTransitionsTo sE fa - sBs = nonLoopTransitionsFrom sE fa - r2 = unionRE $ loops sE fa - ts = [(sA, sB, r r1 r3) | (sA,r1) <- sAs, (sB,r3) <- sBs] - r r1 r3 = concatRE [r1, repeatRE r2, r3] - -epsilonRE :: RE a -epsilonRE = REConcat [] - -nullRE :: RE a -nullRE = REUnion [] - -isNull :: RE a -> Bool -isNull (REUnion []) = True -isNull _ = False - -isEpsilon :: RE a -> Bool -isEpsilon (REConcat []) = True -isEpsilon _ = False - -unionRE :: Ord a => [RE a] -> RE a -unionRE = unionOrId . sortNub . concatMap toList - where - toList (REUnion xs) = xs - toList x = [x] - unionOrId [r] = r - unionOrId rs = REUnion rs - -concatRE :: [RE a] -> RE a -concatRE xs | any isNull xs = nullRE - | otherwise = case concatMap toList xs of - [r] -> r - rs -> REConcat rs - where - toList (REConcat xs) = xs - toList x = [x] - -seqRE :: [a] -> RE a -seqRE = concatRE . map RESymbol - -repeatRE :: RE a -> RE a -repeatRE x | isNull x || isEpsilon x = epsilonRE - | otherwise = RERepeat x - -finalRE :: Ord a => DFA (RE a) -> RE a -finalRE fa = concatRE [repeatRE r1, r2, - repeatRE (unionRE [r3, concatRE [r4, repeatRE r1, r2]])] - where - s0 = startState fa - [sF] = finalStates fa - r1 = unionRE $ loops s0 fa - r2 = unionRE $ map snd $ nonLoopTransitionsTo sF fa - r3 = unionRE $ loops sF fa - r4 = unionRE $ map snd $ nonLoopTransitionsFrom sF fa - -reverseRE :: RE a -> RE a -reverseRE (REConcat xs) = REConcat $ map reverseRE $ reverse xs -reverseRE (REUnion xs) = REUnion (map reverseRE xs) -reverseRE (RERepeat x) = RERepeat (reverseRE x) -reverseRE x = x - -minimizeRE :: Ord a => RE a -> RE a -minimizeRE = reverseRE . mergeForward . reverseRE . mergeForward - -mergeForward :: Ord a => RE a -> RE a -mergeForward (REUnion xs) = - unionRE [concatRE [mergeForward y,mergeForward (unionRE rs)] | (y,rs) <- buildMultiMap (map firstRE xs)] -mergeForward (REConcat (x:xs)) = concatRE [mergeForward x,mergeForward (REConcat xs)] -mergeForward (RERepeat r) = repeatRE (mergeForward r) -mergeForward r = r - -firstRE :: RE a -> (RE a, RE a) -firstRE (REConcat (x:xs)) = (x, REConcat xs) -firstRE r = (r,epsilonRE) - -mapRE :: (a -> b) -> RE a -> RE b -mapRE f = mapRE' (RESymbol . f) - -mapRE' :: (a -> RE b) -> RE a -> RE b -mapRE' f (REConcat xs) = REConcat (map (mapRE' f) xs) -mapRE' f (REUnion xs) = REUnion (map (mapRE' f) xs) -mapRE' f (RERepeat x) = RERepeat (mapRE' f x) -mapRE' f (RESymbol s) = f s - -joinRE :: RE (RE a) -> RE a -joinRE (REConcat xs) = REConcat (map joinRE xs) -joinRE (REUnion xs) = REUnion (map joinRE xs) -joinRE (RERepeat xs) = RERepeat (joinRE xs) -joinRE (RESymbol ss) = ss - -symbolsRE :: RE a -> [a] -symbolsRE (REConcat xs) = concatMap symbolsRE xs -symbolsRE (REUnion xs) = concatMap symbolsRE xs -symbolsRE (RERepeat x) = symbolsRE x -symbolsRE (RESymbol x) = [x] - --- Debugging - -prRE :: RE String -> String -prRE = prRE' 0 - -prRE' _ (REUnion []) = "" -prRE' n (REUnion xs) = p n 1 (concat (intersperse " | " (map (prRE' 1) xs))) -prRE' n (REConcat xs) = p n 2 (unwords (map (prRE' 2) xs)) -prRE' n (RERepeat x) = p n 3 (prRE' 3 x) ++ "*" -prRE' _ (RESymbol s) = s - -p n m s | n >= m = "(" ++ s ++ ")" - | True = s diff --git a/src-3.0/GF/Speech/Relation.hs b/src-3.0/GF/Speech/Relation.hs deleted file mode 100644 index 641d671a9..000000000 --- a/src-3.0/GF/Speech/Relation.hs +++ /dev/null @@ -1,130 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Relation --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/26 17:13:13 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- A simple module for relations. ------------------------------------------------------------------------------ - -module GF.Speech.Relation (Rel, mkRel, mkRel' - , allRelated , isRelatedTo - , transitiveClosure - , reflexiveClosure, reflexiveClosure_ - , symmetricClosure - , symmetricSubrelation, reflexiveSubrelation - , reflexiveElements - , equivalenceClasses - , isTransitive, isReflexive, isSymmetric - , isEquivalence - , isSubRelationOf) where - -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import GF.Data.Utilities - -type Rel a = Map a (Set a) - --- | Creates a relation from a list of related pairs. -mkRel :: Ord a => [(a,a)] -> Rel a -mkRel ps = relates ps Map.empty - --- | Creates a relation from a list pairs of elements and the elements --- related to them. -mkRel' :: Ord a => [(a,[a])] -> Rel a -mkRel' xs = Map.fromListWith Set.union [(x,Set.fromList ys) | (x,ys) <- xs] - -relToList :: Rel a -> [(a,a)] -relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ] - --- | Add a pair to the relation. -relate :: Ord a => a -> a -> Rel a -> Rel a -relate x y r = Map.insertWith Set.union x (Set.singleton y) r - --- | Add a list of pairs to the relation. -relates :: Ord a => [(a,a)] -> Rel a -> Rel a -relates ps r = foldl (\r' (x,y) -> relate x y r') r ps - --- | Checks if an element is related to another. -isRelatedTo :: Ord a => Rel a -> a -> a -> Bool -isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r) - --- | Get the set of elements to which a given element is related. -allRelated :: Ord a => Rel a -> a -> Set a -allRelated r x = fromMaybe Set.empty (Map.lookup x r) - --- | Get all elements in the relation. -domain :: Ord a => Rel a -> Set a -domain r = foldl Set.union (Map.keysSet r) (Map.elems r) - --- | Keep only pairs for which both elements are in the given set. -intersectSetRel :: Ord a => Set a -> Rel a -> Rel a -intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s) - -transitiveClosure :: Ord a => Rel a -> Rel a -transitiveClosure r = fix (Map.map growSet) r - where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys) - -reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined. - -> Rel a -> Rel a -reflexiveClosure_ u r = relates [(x,x) | x <- u] r - --- | Uses 'domain' -reflexiveClosure :: Ord a => Rel a -> Rel a -reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r - -symmetricClosure :: Ord a => Rel a -> Rel a -symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r - -symmetricSubrelation :: Ord a => Rel a -> Rel a -symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r - -reflexiveSubrelation :: Ord a => Rel a -> Rel a -reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r - --- | Get the set of elements which are related to themselves. -reflexiveElements :: Ord a => Rel a -> Set a -reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ] - --- | Keep the related pairs for which the predicate is true. -filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a -filterRel p = purgeEmpty . Map.mapWithKey (Set.filter . p) - --- | Remove keys that map to no elements. -purgeEmpty :: Ord a => Rel a -> Rel a -purgeEmpty r = Map.filter (not . Set.null) r - - --- | Get the equivalence classes from an equivalence relation. -equivalenceClasses :: Ord a => Rel a -> [Set a] -equivalenceClasses r = equivalenceClasses_ (Map.keys r) r - where equivalenceClasses_ [] _ = [] - equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r - where ys = allRelated r x - zs = [x' | x' <- xs, not (x' `Set.member` ys)] - -isTransitive :: Ord a => Rel a -> Bool -isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, - y <- Set.toList ys, z <- Set.toList (allRelated r y)] - -isReflexive :: Ord a => Rel a -> Bool -isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r) - -isSymmetric :: Ord a => Rel a -> Bool -isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r] - -isEquivalence :: Ord a => Rel a -> Bool -isEquivalence r = isReflexive r && isSymmetric r && isTransitive r - -isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool -isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1) diff --git a/src-3.0/GF/Speech/RelationQC.hs b/src-3.0/GF/Speech/RelationQC.hs deleted file mode 100644 index 47f783986..000000000 --- a/src-3.0/GF/Speech/RelationQC.hs +++ /dev/null @@ -1,39 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : RelationQC --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/26 17:13:13 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- QuickCheck properties for GF.Speech.Relation ------------------------------------------------------------------------------ - -module GF.Speech.RelationQC where - -import GF.Speech.Relation - -import Test.QuickCheck - -prop_transitiveClosure_trans :: [(Int,Int)] -> Bool -prop_transitiveClosure_trans ps = isTransitive (transitiveClosure (mkRel ps)) - -prop_symmetricSubrelation_symm :: [(Int,Int)] -> Bool -prop_symmetricSubrelation_symm ps = isSymmetric (symmetricSubrelation (mkRel ps)) - -prop_symmetricSubrelation_sub :: [(Int,Int)] -> Bool -prop_symmetricSubrelation_sub ps = symmetricSubrelation r `isSubRelationOf` r - where r = mkRel ps - -prop_symmetricClosure_symm :: [(Int,Int)] -> Bool -prop_symmetricClosure_symm ps = isSymmetric (symmetricClosure (mkRel ps)) - -prop_reflexiveClosure_refl :: [(Int,Int)] -> Bool -prop_reflexiveClosure_refl ps = isReflexive (reflexiveClosure (mkRel ps)) - -prop_mkEquiv_equiv :: [(Int,Int)] -> Bool -prop_mkEquiv_equiv ps = isEquivalence (mkEquiv ps) - where mkEquiv = transitiveClosure . symmetricClosure . reflexiveClosure . mkRel diff --git a/src-3.0/GF/Speech/SISR.hs b/src-3.0/GF/Speech/SISR.hs deleted file mode 100644 index 3e68a2e55..000000000 --- a/src-3.0/GF/Speech/SISR.hs +++ /dev/null @@ -1,87 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.SISR --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- Abstract syntax and pretty printer for SISR, --- (Semantic Interpretation for Speech Recognition) --- ------------------------------------------------------------------------------ - -module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR, - topCatSISR, profileInitSISR, catSISR, profileFinalSISR) where - -import Data.List - -import GF.Conversion.Types -import GF.Data.Utilities -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), forestName) -import GF.Infra.Ident -import GF.Speech.TransformCFG -import GF.Speech.SRG (SRGNT) - -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -data SISRFormat = - -- SISR Working draft 1 April 2003 - -- http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/ - SISROld - deriving Show - -type SISRTag = [JS.DeclOrExpr] - - -prSISR :: SISRTag -> String -prSISR = JS.printTree - -topCatSISR :: String -> SISRFormat -> SISRTag -topCatSISR c fmt = map JS.DExpr [fmtOut fmt `ass` fmtRef fmt c] - -profileInitSISR :: CFTerm -> SISRFormat -> SISRTag -profileInitSISR t fmt - | null (usedArgs t) = [] - | otherwise = [JS.Decl [JS.DInit args (JS.EArray [])]] - -usedArgs :: CFTerm -> [Int] -usedArgs (CFObj _ ts) = foldr union [] (map usedArgs ts) -usedArgs (CFAbs _ x) = usedArgs x -usedArgs (CFApp x y) = usedArgs x `union` usedArgs y -usedArgs (CFRes i) = [i] -usedArgs _ = [] - -catSISR :: CFTerm -> SRGNT -> SISRFormat -> SISRTag -catSISR t (c,i) fmt - | i `elem` usedArgs t = map JS.DExpr - [JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i)) `ass` fmtRef fmt c] - | otherwise = [] - -profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag -profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term] - where - f (CFObj n ts) = tree (prIdent n) (map f ts) - f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)] - f (CFApp x y) = JS.ECall (f x) [f y] - f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i)) - f (CFVar v) = JS.EVar (var v) - f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr typ)] - -fmtOut SISROld = JS.EVar (JS.Ident "$") - -fmtRef SISROld c = JS.EVar (JS.Ident ("$" ++ c)) - -args = JS.Ident "a" - -var v = JS.Ident ("x" ++ show v) - -field x y = JS.EMember x (JS.Ident y) - -ass = JS.EAssign - -tree n xs = obj [("name", JS.EStr n), ("args", JS.EArray xs)] - -obj ps = JS.EObj [JS.Prop (JS.StringPropName x) y | (x,y) <- ps] - diff --git a/src-3.0/GF/Speech/SRG.hs b/src-3.0/GF/Speech/SRG.hs deleted file mode 100644 index 19b6c1c1b..000000000 --- a/src-3.0/GF/Speech/SRG.hs +++ /dev/null @@ -1,235 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SRG --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.20 $ --- --- Representation of, conversion to, and utilities for --- printing of a general Speech Recognition Grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar ------------------------------------------------------------------------------ - -module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, - SRGCat, SRGNT, CFTerm - , makeSRG - , makeSimpleSRG - , makeNonRecursiveSRG - , lookupFM_, prtS - , cfgCatToGFCat, srgTopCats - ) where - -import GF.Data.Operations -import GF.Data.Utilities -import GF.Infra.Ident -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), NameProfile(..) - , Profile(..), SyntaxForest - , filterCats, mapSymbol, symbol) -import GF.Conversion.Types -import GF.Infra.Print -import GF.Speech.TransformCFG -import GF.Speech.Relation -import GF.Speech.FiniteState -import GF.Speech.RegExp -import GF.Speech.CFGToFiniteState -import GF.Infra.Option -import GF.Probabilistic.Probabilistic (Probs) -import GF.Compile.ShellState (StateGrammar, stateProbs, stateOptions, cncId) - -import Data.List -import Data.Maybe (fromMaybe, maybeToList) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import Debug.Trace - -data SRG = SRG { grammarName :: String -- ^ grammar name - , startCat :: SRGCat -- ^ start category name - , origStartCat :: String -- ^ original start category name - , grammarLanguage :: Maybe String -- ^ The language for which the grammar - -- is intended, e.g. en-UK - , rules :: [SRGRule] - } - deriving (Eq,Show) - -data SRGRule = SRGRule SRGCat String [SRGAlt] -- ^ SRG category name, original category name - -- and productions - deriving (Eq,Show) - --- | maybe a probability, a rule name and an EBNF right-hand side -data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem - deriving (Eq,Show) - -type SRGItem = RE (Symbol SRGNT Token) - -type SRGCat = String - --- | An SRG non-terminal. Category name and its number in the profile. -type SRGNT = (SRGCat, Int) - --- | SRG category name and original name -type CatName = (SRGCat,String) - -type CatNames = Map String String - --- | Create a non-left-recursive SRG. --- FIXME: the probabilities in the returned --- grammar may be meaningless. -makeSimpleSRG :: Options -- ^ Grammar options - -> StateGrammar - -> SRG -makeSimpleSRG opt s = makeSRG preprocess opt s - where - preprocess origStart = traceStats "After mergeIdentical" - . mergeIdentical - . traceStats "After removeLeftRecursion" - . removeLeftRecursion origStart - . traceStats "After topDownFilter" - . topDownFilter origStart - . traceStats "After bottomUpFilter" - . bottomUpFilter - . traceStats "After removeCycles" - . removeCycles - . traceStats "Inital CFG" - -traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g - -stats g = "Categories: " ++ show (countCats g) - ++ " Rules: " ++ show (countRules g) - -makeNonRecursiveSRG :: Options - -> StateGrammar - -> SRG -makeNonRecursiveSRG opt s = renameSRG $ - SRG { grammarName = prIdent (cncId s), - startCat = start, - origStartCat = origStart, - grammarLanguage = getSpeechLanguage opt s, - rules = rs } - where - origStart = getStartCatCF opt s - MFA start dfas = cfgToMFA opt s - rs = [SRGRule l l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas] - where dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re - dummyCFTerm = CFMeta "dummy" - dummySRGNT = mapSymbol (\c -> (c,0)) id - -makeSRG :: (Cat_ -> CFRules -> CFRules) - -> Options -- ^ Grammar options - -> StateGrammar - -> SRG -makeSRG preprocess opt s = renameSRG $ - SRG { grammarName = name, - startCat = origStart, - origStartCat = origStart, - grammarLanguage = getSpeechLanguage opt s, - rules = rs } - where - name = prIdent (cncId s) - origStart = getStartCatCF opt s - (_,cfgRules) = unzip $ allRulesGrouped $ preprocess origStart $ cfgToCFRules s - rs = map (cfgRulesToSRGRule (stateProbs s)) cfgRules - --- | Give names on the form NameX to all categories. -renameSRG :: SRG -> SRG -renameSRG srg = srg { startCat = renameCat (startCat srg), - rules = map renameRule (rules srg) } - where - names = mkCatNames (grammarName srg) (allSRGCats srg) - renameRule (SRGRule _ origCat alts) = SRGRule (renameCat origCat) origCat (map renameAlt alts) - renameAlt (SRGAlt mp n rhs) = SRGAlt mp n (mapRE renameSymbol rhs) - renameSymbol = mapSymbol (\ (c,x) -> (renameCat c, x)) id - renameCat = lookupFM_ names - -getSpeechLanguage :: Options -> StateGrammar -> Maybe String -getSpeechLanguage opt s = - fmap (replace '_' '-') $ getOptVal (addOptions opt (stateOptions s)) speechLanguage - --- FIXME: merge alternatives with same rhs and profile but different probabilities -cfgRulesToSRGRule :: Probs -> [CFRule_] -> SRGRule -cfgRulesToSRGRule probs rs@(r:_) = SRGRule origCat origCat rhs - where - origCat = lhsCat r - alts = [((n,ruleProb probs r),mkSRGSymbols 0 ss) | CFRule c ss n <- rs] - rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ] - - mkSRGSymbols _ [] = [] - mkSRGSymbols i (Cat c:ss) = Cat (c,i) : mkSRGSymbols (i+1) ss - mkSRGSymbols i (Tok t:ss) = Tok t : mkSRGSymbols i ss - -ruleProb :: Probs -> CFRule_ -> Maybe Double -ruleProb probs r = lookupProb probs (ruleFun r) - --- FIXME: move to GF.Probabilistic.Probabilistic? -lookupProb :: Probs -> Ident -> Maybe Double -lookupProb probs i = lookupTree prIdent i probs - -mkCatNames :: String -- ^ Category name prefix - -> [String] -- ^ Original category names - -> Map String String -- ^ Maps original names to SRG names -mkCatNames prefix origNames = Map.fromList (zip origNames names) - where names = [prefix ++ "_" ++ show x | x <- [0..]] - - -allSRGCats :: SRG -> [String] -allSRGCats SRG { rules = rs } = [c | SRGRule c _ _ <- rs] - -cfgCatToGFCat :: SRGCat -> Maybe String -cfgCatToGFCat c - -- categories introduced by removeLeftRecursion contain dashes - | '-' `elem` c = Nothing - -- some categories introduced by -conversion=finite have the form - -- "{fun:cat}..." - | "{" `isPrefixOf` c = case dropWhile (/=':') $ takeWhile (/='}') $ tail c of - ':':c' -> Just c' - _ -> error $ "cfgCatToGFCat: Strange category " ++ show c - | otherwise = Just $ takeWhile (/='{') c - -srgTopCats :: SRG -> [(String,[SRGCat])] -srgTopCats srg = buildMultiMap [(oc, cat) | SRGRule cat origCat _ <- rules srg, - oc <- maybeToList $ cfgCatToGFCat origCat] - --- --- * Size-optimized EBNF SRGs --- - -srgItem :: [[Symbol SRGNT Token]] -> SRGItem -srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats) --- non-optimizing version: ---srgItem = unionRE . map seqRE - --- | Merges a list of right-hand sides which all have the same --- sequence of non-terminals. -mergeItems :: [[Symbol SRGNT Token]] -> SRGItem -mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens - -groupTokens :: [Symbol SRGNT Token] -> [Symbol SRGNT [Token]] -groupTokens [] = [] -groupTokens (Tok t:ss) = case groupTokens ss of - Tok ts:ss' -> Tok (t:ts):ss' - ss' -> Tok [t]:ss' -groupTokens (Cat c:ss) = Cat c : groupTokens ss - -ungroupTokens :: RE (Symbol SRGNT [Token]) -> RE (Symbol SRGNT Token) -ungroupTokens = joinRE . mapRE (symbol (RESymbol . Cat) (REConcat . map (RESymbol . Tok))) - --- --- * Utilities for building and printing SRGs --- - -lookupFM_ :: (Ord key, Show key) => Map key elt -> key -> elt -lookupFM_ fm k = Map.findWithDefault err k fm - where err = error $ "Key not found: " ++ show k - ++ "\namong " ++ show (Map.keys fm) - -prtS :: Print a => a -> ShowS -prtS = showString . prt diff --git a/src-3.0/GF/Speech/TransformCFG.hs b/src-3.0/GF/Speech/TransformCFG.hs deleted file mode 100644 index 3d7ebd809..000000000 --- a/src-3.0/GF/Speech/TransformCFG.hs +++ /dev/null @@ -1,378 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TransformCFG --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.24 $ --- --- This module does some useful transformations on CFGs. --- --- peb thinks: most of this module should be moved to GF.Conversion... ------------------------------------------------------------------------------ - -module GF.Speech.TransformCFG where - -import GF.Canon.CanonToGFCC (canon2gfcc) -import qualified GF.GFCC.CId as C -import GF.GFCC.Macros (lookType,catSkeleton) -import GF.GFCC.DataGFCC (GFCC) -import GF.Conversion.Types -import GF.CF.PPrCF (prCFCat) -import GF.Data.Utilities -import GF.Formalism.CFG -import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, - NameProfile(..), Profile(..), name2fun, forestName) -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.Print -import GF.Speech.Relation -import GF.Compile.ShellState (StateGrammar, stateCFG, stateGrammarST, startCatStateOpts, stateOptions) - -import Control.Monad -import Control.Monad.State (State, get, put, evalState) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List -import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) -import Data.Set (Set) -import qualified Data.Set as Set - --- not very nice to replace the structured CFCat type with a simple string -type CFRule_ = CFRule Cat_ CFTerm Token - -data CFTerm - = CFObj Fun [CFTerm] -- ^ an abstract syntax function with arguments - | CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id. - | CFApp CFTerm CFTerm -- ^ Application - | CFRes Int -- ^ The result of the n:th (0-based) non-terminal - | CFVar Int -- ^ A lambda-bound variable - | CFMeta String -- ^ A metavariable - deriving (Eq,Ord,Show) - -type Cat_ = String -type CFSymbol_ = Symbol Cat_ Token - -type CFRules = Map Cat_ (Set CFRule_) - - -cfgToCFRules :: StateGrammar -> CFRules -cfgToCFRules s = - groupProds [CFRule (catToString c) (map symb r) (nameToTerm n) - | CFRule c r n <- cfg] - where cfg = stateCFG s - symb = mapSymbol catToString id - catToString = prt - gfcc = stateGFCC s - nameToTerm (Name IW [Unify [n]]) = CFRes n - nameToTerm (Name f@(IC c) prs) = - CFObj f (zipWith profileToTerm args prs) - where (args,_) = catSkeleton $ lookType gfcc (C.CId c) - nameToTerm n = error $ "cfgToCFRules.nameToTerm" ++ show n - profileToTerm (C.CId t) (Unify []) = CFMeta t - profileToTerm _ (Unify xs) = CFRes (last xs) -- FIXME: unify - profileToTerm (C.CId t) (Constant f) = maybe (CFMeta t) (\x -> CFObj x []) (forestName f) - -getStartCat :: Options -> StateGrammar -> String -getStartCat opts sgr = prCFCat (startCatStateOpts opts' sgr) - where opts' = addOptions opts (stateOptions sgr) - -getStartCatCF :: Options -> StateGrammar -> String -getStartCatCF opts sgr = getStartCat opts sgr ++ "{}.s" - -stateGFCC :: StateGrammar -> GFCC -stateGFCC = canon2gfcc noOptions . stateGrammarST - --- * Grammar filtering - --- | Removes all directly and indirectly cyclic productions. --- FIXME: this may be too aggressive, only one production --- needs to be removed to break a given cycle. But which --- one should we pick? --- FIXME: Does not (yet) remove productions which are cyclic --- because of empty productions. -removeCycles :: CFRules -> CFRules -removeCycles = groupProds . f . allRules - where f rs = filter (not . isCycle) rs - where alias = transitiveClosure $ mkRel [(c,c') | CFRule c [Cat c'] _ <- rs] - isCycle (CFRule c [Cat c'] _) = isRelatedTo alias c' c - isCycle _ = False - --- | Better bottom-up filter that also removes categories which contain no finite --- strings. -bottomUpFilter :: CFRules -> CFRules -bottomUpFilter gr = fix grow Map.empty - where grow g = g `unionCFRules` filterCFRules (all (okSym g) . ruleRhs) gr - okSym g = symbol (`elem` allCats g) (const True) - --- | Removes categories which are not reachable from the start category. -topDownFilter :: Cat_ -> CFRules -> CFRules -topDownFilter start rules = filterCFRulesCats (isRelatedTo uses start) rules - where - rhsCats = [ (lhsCat r, c') | r <- allRules rules, c' <- filterCats (ruleRhs r) ] - uses = reflexiveClosure_ (allCats rules) $ transitiveClosure $ mkRel rhsCats - --- | Merges categories with identical right-hand-sides. --- FIXME: handle probabilities -mergeIdentical :: CFRules -> CFRules -mergeIdentical g = groupProds $ map subst $ allRules g - where - -- maps categories to their replacement - m = Map.fromList [(y,concat (intersperse "+" xs)) - | (_,xs) <- buildMultiMap [(rulesKey rs,c) | (c,rs) <- Map.toList g], y <- xs] - -- build data to compare for each category: a set of name,rhs pairs - rulesKey = Set.map (\ (CFRule _ r n) -> (n,r)) - subst (CFRule c r n) = CFRule (substCat c) (map (mapSymbol substCat id) r) n - substCat c = Map.findWithDefault (error $ "mergeIdentical: " ++ c) c m - --- * Removing left recursion - --- The LC_LR algorithm from --- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf -removeLeftRecursion :: Cat_ -> CFRules -> CFRules -removeLeftRecursion start gr - = groupProds $ concat [scheme1, scheme2, scheme3, scheme4] - where - scheme1 = [CFRule a [x,Cat a_x] n' | - a <- retainedLeftRecursive, - x <- properLeftCornersOf a, - not (isLeftRecursive x), - let a_x = mkCat (Cat a) x, - -- this is an extension of LC_LR to avoid generating - -- A-X categories for which there are no productions: - a_x `Set.member` newCats, - let n' = symbol (\_ -> CFApp (CFRes 1) (CFRes 0)) - (\_ -> CFRes 0) x] - scheme2 = [CFRule a_x (beta++[Cat a_b]) n' | - a <- retainedLeftRecursive, - b@(Cat b') <- properLeftCornersOf a, - isLeftRecursive b, - CFRule _ (x:beta) n <- catRules gr b', - let a_x = mkCat (Cat a) x, - let a_b = mkCat (Cat a) b, - let i = length $ filterCats beta, - let n' = symbol (\_ -> CFAbs 1 (CFApp (CFRes i) (shiftTerm n))) - (\_ -> CFApp (CFRes i) n) x] - scheme3 = [CFRule a_x beta n' | - a <- retainedLeftRecursive, - x <- properLeftCornersOf a, - CFRule _ (x':beta) n <- catRules gr a, - x == x', - let a_x = mkCat (Cat a) x, - let n' = symbol (\_ -> CFAbs 1 (shiftTerm n)) - (\_ -> n) x] - scheme4 = catSetRules gr $ Set.fromList $ filter (not . isLeftRecursive . Cat) cats - - newCats = Set.fromList (map lhsCat (scheme2 ++ scheme3)) - - shiftTerm :: CFTerm -> CFTerm - shiftTerm (CFObj f ts) = CFObj f (map shiftTerm ts) - shiftTerm (CFRes 0) = CFVar 1 - shiftTerm (CFRes n) = CFRes (n-1) - shiftTerm t = t - -- note: the rest don't occur in the original grammar - - cats = allCats gr - rules = allRules gr - - directLeftCorner = mkRel [(Cat c,t) | CFRule c (t:_) _ <- allRules gr] - leftCorner = reflexiveClosure_ (map Cat cats) $ transitiveClosure directLeftCorner - properLeftCorner = transitiveClosure directLeftCorner - properLeftCornersOf = Set.toList . allRelated properLeftCorner . Cat - isProperLeftCornerOf = flip (isRelatedTo properLeftCorner) - - leftRecursive = reflexiveElements properLeftCorner - isLeftRecursive = (`Set.member` leftRecursive) - - retained = start `Set.insert` - Set.fromList [a | r <- allRules (filterCFRulesCats (not . isLeftRecursive . Cat) gr), - Cat a <- ruleRhs r] - isRetained = (`Set.member` retained) - - retainedLeftRecursive = filter (isLeftRecursive . Cat) $ Set.toList retained - -mkCat :: CFSymbol_ -> CFSymbol_ -> Cat_ -mkCat x y = showSymbol x ++ "-" ++ showSymbol y - where showSymbol = symbol id show - -{- - --- Paull's algorithm, see --- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf -removeLeftRecursion :: Cat_ -> CFRules -> CFRules -removeLeftRecursion start rs = removeDirectLeftRecursions $ map handleProds rs - where - handleProds (c, r) = (c, concatMap handleProd r) - handleProd (CFRule ai (Cat aj:alpha) n) | aj < ai = - -- FIXME: for non-recursive categories, this changes - -- the grammar unneccessarily, maybe we can use mutRecCats - -- to make this less invasive - -- FIXME: this will give multiple rules with the same name, - -- which may mess up the probabilities. - [CFRule ai (beta ++ alpha) n | CFRule _ beta _ <- lookup' aj rs] - handleProd r = [r] - -removeDirectLeftRecursions :: CFRules -> CFRules -removeDirectLeftRecursions = concat . flip evalState 0 . mapM removeDirectLeftRecursion - -removeDirectLeftRecursion :: (Cat_,[CFRule_]) -- ^ All productions for a category - -> State Int CFRules -removeDirectLeftRecursion (a,rs) - | null dr = return [(a,rs)] - | otherwise = - do - a' <- fresh a - let as = maybeEndWithA' nr - is = [CFRule a' (tail r) n | CFRule _ r n <- dr] - a's = maybeEndWithA' is - -- the not null constraint here avoids creating new - -- left recursive (cyclic) rules. - maybeEndWithA' xs = xs ++ [CFRule c (r++[Cat a']) n | CFRule c r n <- xs, - not (null r)] - return [(a, as), (a', a's)] - where - (dr,nr) = partition isDirectLeftRecursive rs - fresh x = do { n <- get; put (n+1); return $ x ++ "-" ++ show n } - -isDirectLeftRecursive :: CFRule_ -> Bool -isDirectLeftRecursive (CFRule c (Cat c':_) _) = c == c' -isDirectLeftRecursive _ = False - --} - --- | Get the sets of mutually recursive non-terminals for a grammar. -mutRecCats :: Bool -- ^ If true, all categories will be in some set. - -- If false, only recursive categories will be included. - -> CFRules -> [Set Cat_] -mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r - where r = mkRel [(c,c') | CFRule c ss _ <- allRules g, Cat c' <- ss] - refl = if incAll then reflexiveClosure_ (allCats g) else reflexiveSubrelation - --- --- * Approximate context-free grammars with regular grammars. --- - --- Use the transformation algorithm from \"Regular Approximation of Context-free --- Grammars through Approximation\", Mohri and Nederhof, 2000 --- to create an over-generating regular frammar for a context-free --- grammar -makeRegular :: CFRules -> CFRules -makeRegular g = groupProds $ concatMap trSet (mutRecCats True g) - where trSet cs | allXLinear cs rs = rs - | otherwise = concatMap handleCat csl - where csl = Set.toList cs - rs = catSetRules g cs - handleCat c = [CFRule c' [] (mkCFTerm (c++"-empty"))] -- introduce A' -> e - ++ concatMap (makeRightLinearRules c) (catRules g c) - where c' = newCat c - makeRightLinearRules b' (CFRule c ss n) = - case ys of - [] -> newRule b' (xs ++ [Cat (newCat c)]) n -- no non-terminals left - (Cat b:zs) -> newRule b' (xs ++ [Cat b]) n - ++ makeRightLinearRules (newCat b) (CFRule c zs n) - where (xs,ys) = break (`catElem` cs) ss - -- don't add rules on the form A -> A - newRule c rhs n | rhs == [Cat c] = [] - | otherwise = [CFRule c rhs n] - newCat c = c ++ "$" - --- --- * CFG rule utilities --- - --- | Group productions by their lhs categories -groupProds :: [CFRule_] -> CFRules -groupProds = Map.fromListWith Set.union . map (\r -> (lhsCat r,Set.singleton r)) - -allRules :: CFRules -> [CFRule_] -allRules = concat . map Set.toList . Map.elems - -allRulesGrouped :: CFRules -> [(Cat_,[CFRule_])] -allRulesGrouped = Map.toList . Map.map Set.toList - -allCats :: CFRules -> [Cat_] -allCats = Map.keys - -catRules :: CFRules -> Cat_ -> [CFRule_] -catRules rs c = Set.toList $ Map.findWithDefault Set.empty c rs - -catSetRules :: CFRules -> Set Cat_ -> [CFRule_] -catSetRules g cs = allRules $ Map.filterWithKey (\c _ -> c `Set.member` cs) g - -cleanCFRules :: CFRules -> CFRules -cleanCFRules = Map.filter (not . Set.null) - -unionCFRules :: CFRules -> CFRules -> CFRules -unionCFRules = Map.unionWith Set.union - -filterCFRules :: (CFRule_ -> Bool) -> CFRules -> CFRules -filterCFRules p = cleanCFRules . Map.map (Set.filter p) - -filterCFRulesCats :: (Cat_ -> Bool) -> CFRules -> CFRules -filterCFRulesCats p = Map.filterWithKey (\c _ -> p c) - -countCats :: CFRules -> Int -countCats = Map.size . cleanCFRules - -countRules :: CFRules -> Int -countRules = length . allRules - -lhsCat :: CFRule c n t -> c -lhsCat (CFRule c _ _) = c - -ruleRhs :: CFRule c n t -> [Symbol c t] -ruleRhs (CFRule _ ss _) = ss - -ruleFun :: CFRule_ -> Fun -ruleFun (CFRule _ _ t) = f t - where f (CFObj n _) = n - f (CFApp _ x) = f x - f (CFAbs _ x) = f x - f _ = IC "" - --- | Checks if a symbol is a non-terminal of one of the given categories. -catElem :: Ord c => Symbol c t -> Set c -> Bool -catElem s cs = symbol (`Set.member` cs) (const False) s - --- | Check if any of the categories used on the right-hand side --- are in the given list of categories. -anyUsedBy :: Eq c => [c] -> CFRule c n t -> Bool -anyUsedBy cs (CFRule _ ss _) = any (`elem` cs) (filterCats ss) - -mkCFTerm :: String -> CFTerm -mkCFTerm n = CFObj (IC n) [] - -ruleIsNonRecursive :: Ord c => Set c -> CFRule c n t -> Bool -ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs - -noCatsInSet :: Ord c => Set c -> [Symbol c t] -> Bool -noCatsInSet cs = not . any (`catElem` cs) - --- | Check if all the rules are right-linear, or all the rules are --- left-linear, with respect to given categories. -allXLinear :: Ord c => Set c -> [CFRule c n t] -> Bool -allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs - --- | Checks if a context-free rule is right-linear. -isRightLinear :: Ord c => - Set c -- ^ The categories to consider - -> CFRule c n t -- ^ The rule to check for right-linearity - -> Bool -isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs - --- | Checks if a context-free rule is left-linear. -isLeftLinear :: Ord c => - Set c -- ^ The categories to consider - -> CFRule c n t -- ^ The rule to check for left-linearity - -> Bool -isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs - -prCFRules :: CFRules -> String -prCFRules = unlines . map prRule . allRules - where - prRule r = lhsCat r ++ " --> " ++ unwords (map prSym (ruleRhs r)) - prSym = symbol id (\t -> "\""++ t ++"\"") diff --git a/src-3.0/GF/System/ATKSpeechInput.hs b/src-3.0/GF/System/ATKSpeechInput.hs deleted file mode 100644 index 4b50293af..000000000 --- a/src-3.0/GF/System/ATKSpeechInput.hs +++ /dev/null @@ -1,137 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.ATKSpeechInput --- Maintainer : BB --- Stability : (stable) --- Portability : (non-portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Use ATK and Speech.ATKRec for speech input. ------------------------------------------------------------------------------ - -module GF.System.ATKSpeechInput (recognizeSpeech) where - -import GF.Infra.Ident (Ident, prIdent) -import GF.Infra.Option -import GF.Conversion.Types (CGrammar) -import GF.Speech.PrSLF - -import Speech.ATKRec - -import Control.Monad -import Data.Maybe -import Data.IORef -import System.Environment -import System.IO -import System.IO.Unsafe - -data ATKLang = ATKLang { - hmmlist :: FilePath, - mmf0 :: FilePath, - mmf1 :: FilePath, - dict :: FilePath, - opts :: [(String,String)] - } - -atk_home_error = "The environment variable ATK_HOME is not set. " - ++ "It should contain the path to your copy of ATK." - -gf_atk_cfg_error = "The environment variable GF_ATK_CFG is not set. " - ++ "It should contain the path to your GF ATK configuration" - ++ " file. A default version of this file can be found" - ++ " in GF/src/gf_atk.cfg" - -getLanguage :: String -> IO ATKLang -getLanguage l = - case l of - "en_UK" -> do - atk_home <- getEnv_ "ATK_HOME" atk_home_error - let res = atk_home ++ "/Resources" - return $ ATKLang { - hmmlist = res ++ "/UK_SI_ZMFCC/hmmlistbg", - mmf0 = res ++ "/UK_SI_ZMFCC/WI4", - mmf1 = res ++ "/UK_SI_ZMFCC/BGHMM2", - dict = res ++ "/beep.dct", - opts = [("TARGETKIND", "MFCC_0_D_A_Z"), - ("HPARM:CMNDEFAULT", res ++ "/UK_SI_ZMFCC/cepmean")] - } - "sv_SE" -> do - let res = "/home/bjorn/projects/atkswe/numerals-swe/final" - return $ ATKLang { - hmmlist = res ++ "/hmm_tri/hmmlist", - mmf0 = res ++ "/hmm_tri/macros", - mmf1 = res ++ "/hmm_tri/hmmdefs", - dict = res ++ "/NumeralsSwe.dct", - opts = [("TARGETKIND", "MFCC_0_D_A")] - } - _ -> fail $ "ATKSpeechInput: language " ++ l ++ " not supported" - --- | Current language for which we have loaded the HMM --- and dictionary. -{-# NOINLINE currentLang #-} -currentLang :: IORef (Maybe String) -currentLang = unsafePerformIO $ newIORef Nothing - --- | Initializes the ATK, loading the given language. --- ATK must not be initialized when calling this function. -loadLang :: String -> IO () -loadLang lang = - do - l <- getLanguage lang - config <- getEnv_ "GF_ATK_CFG" gf_atk_cfg_error - hPutStrLn stderr $ "Initializing ATK..." - initialize (Just config) (opts l) - let hmmName = "hmm_" ++ lang - dictName = "dict_" ++ lang - hPutStrLn stderr $ "Initializing ATK (" ++ lang ++ ")..." - loadHMMSet hmmName (hmmlist l) (mmf0 l) (mmf1 l) - loadDict dictName (dict l) - writeIORef currentLang (Just lang) - -initATK :: String -> IO () -initATK lang = - do - ml <- readIORef currentLang - case ml of - Nothing -> loadLang lang - Just l | l == lang -> return () - | otherwise -> do - deinitialize - loadLang lang - -recognizeSpeech :: Ident -- ^ Grammar name - -> String -- ^ Language, e.g. en_UK - -> CGrammar -- ^ Context-free grammar for input - -> String -- ^ Start category name - -> Int -- ^ Number of utterances - -> IO [String] -recognizeSpeech name language cfg start number = - do - let slf = slfPrinter name start cfg - n = prIdent name - hmmName = "hmm_" ++ language - dictName = "dict_" ++ language - slfName = "gram_" ++ n - recName = "rec_" ++ language ++ "_" ++ n - writeFile "debug.net" slf - initATK language - hPutStrLn stderr $ "Loading grammar " ++ n ++ " ..." - loadGrammarString slfName slf - createRecognizer recName hmmName dictName slfName - hPutStrLn stderr $ "Listening in category " ++ start ++ "..." - s <- replicateM number (recognize recName) - return s - - -getEnv_ :: String -- ^ Name of environment variable - -> String -- ^ Message to fail with if the variable is not set. - -> IO String -getEnv_ e err = - do - env <- getEnvironment - case lookup e env of - Just v -> return v - Nothing -> fail err diff --git a/src-3.0/GF/System/Arch.hs b/src-3.0/GF/System/Arch.hs deleted file mode 100644 index c0dac3644..000000000 --- a/src-3.0/GF/System/Arch.hs +++ /dev/null @@ -1,90 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Arch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 14:55:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- architecture\/compiler dependent definitions for unix\/hbc ------------------------------------------------------------------------------ - -module GF.System.Arch ( - myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime, - welcomeArch, fetchCommand, laterModTime) where - -import System.Time -import System.Random -import System.CPUTime -import Control.Monad (filterM) -import System.Directory - -import GF.System.Readline (fetchCommand) - ----- import qualified UnicodeF as U --(fudlogueWrite) - --- architecture/compiler dependent definitions for unix/hbc - -myStdGen :: Int -> IO StdGen --- ---- myStdGen _ = newStdGen --- gives always the same result -myStdGen int0 = do - t0 <- getClockTime - cal <- toCalendarTime t0 - let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000) - return $ mkStdGen int - -prCPU :: Integer -> IO Integer -prCPU cpu = do - cpu' <- getCPUTime - putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec") - return cpu' - -welcomeArch :: String -welcomeArch = "This is the system compiled with ghc." - --- | selects the one with the later modification time of two -selectLater :: FilePath -> FilePath -> IO FilePath -selectLater x y = do - ex <- doesFileExist x - if not ex - then return y --- which may not exist - else do - ey <- doesFileExist y - if not ey - then return x - else do - tx <- getModificationTime x - ty <- getModificationTime y - return $ if tx < ty then y else x - --- | a file is considered modified also if it has not been read yet --- --- new 23\/2\/2004: the environment ofs has just module names -modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath] -modifiedFiles ofs fs = do - filterM isModified fs - where - isModified file = case lookup (justModName file) ofs of - Just to -> do - t <- getModificationTime file - return $ to < t - _ -> return True - - justModName = - reverse . takeWhile (/='/') . tail . dropWhile (/='.') . reverse - -type ModTime = ClockTime - -laterModTime :: ModTime -> ModTime -> Bool -laterModTime = (>) - -getModTime :: FilePath -> IO (Maybe ModTime) -getModTime f = do - b <- doesFileExist f - if b then (getModificationTime f >>= return . Just) else return Nothing - -getNowTime :: IO ModTime -getNowTime = getClockTime diff --git a/src-3.0/GF/System/ArchEdit.hs b/src-3.0/GF/System/ArchEdit.hs deleted file mode 100644 index 39b558cef..000000000 --- a/src-3.0/GF/System/ArchEdit.hs +++ /dev/null @@ -1,30 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ArchEdit --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:46:15 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.System.ArchEdit ( - fudlogueEdit, fudlogueWrite, fudlogueWriteUni - ) where - -fudlogueEdit :: a -> b -> IO () -fudlogueEdit _ _ = do - putStrLn "sorry no fudgets available in Hugs" - return () - -fudlogueWrite :: a -> b -> IO () -fudlogueWrite _ _ = do - putStrLn "sorry no fudgets available in Hugs" - -fudlogueWriteUni :: a -> b -> IO () -fudlogueWriteUni _ _ = do - putStrLn "sorry no fudgets available in Hugs" diff --git a/src-3.0/GF/System/NoReadline.hs b/src-3.0/GF/System/NoReadline.hs deleted file mode 100644 index 138ba4e28..000000000 --- a/src-3.0/GF/System/NoReadline.hs +++ /dev/null @@ -1,27 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.NoReadline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Do not use readline. ------------------------------------------------------------------------------ - -module GF.System.NoReadline (fetchCommand) where - -import System.IO.Error (try) -import System.IO (stdout,hFlush) - -fetchCommand :: String -> IO (String) -fetchCommand s = do - putStr s - hFlush stdout - res <- try getLine - case res of - Left e -> return "q" - Right l -> return l diff --git a/src-3.0/GF/System/NoSignal.hs b/src-3.0/GF/System/NoSignal.hs deleted file mode 100644 index 5d82a431e..000000000 --- a/src-3.0/GF/System/NoSignal.hs +++ /dev/null @@ -1,29 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.NoSignal --- Maintainer : Bjorn Bringert --- Stability : (stability) --- Portability : (portability) --- --- > CVS $Date: 2005/11/11 11:12:50 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Dummy implementation of signal handling. ------------------------------------------------------------------------------ - -module GF.System.NoSignal where - -import Control.Exception (Exception,catch) -import Prelude hiding (catch) - -{-# NOINLINE runInterruptibly #-} -runInterruptibly :: IO a -> IO (Either Exception a) ---runInterruptibly = fmap Right -runInterruptibly a = - p `catch` h - where p = a >>= \x -> return $! Right $! x - h e = return $ Left e - -blockInterrupt :: IO a -> IO a -blockInterrupt = id diff --git a/src-3.0/GF/System/NoSpeechInput.hs b/src-3.0/GF/System/NoSpeechInput.hs deleted file mode 100644 index 04197ce92..000000000 --- a/src-3.0/GF/System/NoSpeechInput.hs +++ /dev/null @@ -1,28 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.NoSpeechInput --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Dummy speech input. ------------------------------------------------------------------------------ - -module GF.System.NoSpeechInput (recognizeSpeech) where - -import GF.Infra.Ident (Ident) -import GF.Infra.Option (Options) -import GF.Conversion.Types (CGrammar) - - -recognizeSpeech :: Ident -- ^ Grammar name - -> String -- ^ Language, e.g. en_UK - -> CGrammar -- ^ Context-free grammar for input - -> String -- ^ Start category name - -> Int -- ^ Number of utterances - -> IO [String] -recognizeSpeech _ _ _ _ _ = fail "No speech input available" diff --git a/src-3.0/GF/System/Readline.hs b/src-3.0/GF/System/Readline.hs deleted file mode 100644 index c12493f98..000000000 --- a/src-3.0/GF/System/Readline.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -cpp #-} - ----------------------------------------------------------------------- --- | --- Module : GF.System.Readline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Uses the right readline library to read user input. ------------------------------------------------------------------------------ - -module GF.System.Readline (fetchCommand) where - -#ifdef USE_READLINE - -import GF.System.UseReadline (fetchCommand) - -#else - -import GF.System.NoReadline (fetchCommand) - -#endif diff --git a/src-3.0/GF/System/Signal.hs b/src-3.0/GF/System/Signal.hs deleted file mode 100644 index fe8a12483..000000000 --- a/src-3.0/GF/System/Signal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -cpp #-} - ----------------------------------------------------------------------- --- | --- Module : GF.System.Signal --- Maintainer : Bjorn Bringert --- Stability : (stability) --- Portability : (portability) --- --- > CVS $Date: 2005/11/11 11:12:50 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Import the right singal handling module. ------------------------------------------------------------------------------ - -module GF.System.Signal (runInterruptibly,blockInterrupt) where - -#ifdef USE_INTERRUPT - -import GF.System.UseSignal (runInterruptibly,blockInterrupt) - -#else - -import GF.System.NoSignal (runInterruptibly,blockInterrupt) - -#endif diff --git a/src-3.0/GF/System/SpeechInput.hs b/src-3.0/GF/System/SpeechInput.hs deleted file mode 100644 index 6c2374473..000000000 --- a/src-3.0/GF/System/SpeechInput.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -cpp #-} - ----------------------------------------------------------------------- --- | --- Module : GF.System.SpeechInput --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Uses the right speech recognition library for speech input. ------------------------------------------------------------------------------ - -module GF.System.SpeechInput (recognizeSpeech) where - -#ifdef USE_ATK - -import GF.System.ATKSpeechInput (recognizeSpeech) - -#else - -import GF.System.NoSpeechInput (recognizeSpeech) - -#endif diff --git a/src-3.0/GF/System/Tracing.hs b/src-3.0/GF/System/Tracing.hs deleted file mode 100644 index 71bacfb75..000000000 --- a/src-3.0/GF/System/Tracing.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# OPTIONS -cpp #-} - ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/26 09:54:11 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Tracing utilities for debugging purposes. --- If the CPP symbol TRACING is set, then the debugging output is shown. ------------------------------------------------------------------------------ - - -module GF.System.Tracing - (trace, trace2, traceM, traceCall, tracePrt, traceCalcFirst) where - -import qualified Debug.Trace as Trace - --- | emit a string inside braces, before(?) calculating the value: --- @{str}@ -trace :: String -> a -> a - --- | emit function name and debugging output: --- @{fun: out}@ -trace2 :: String -> String -> a -> a - --- | monadic version of 'trace2' -traceM :: Monad m => String -> String -> m () - --- | show when a value is starting to be calculated (with a '+'), --- and when it is finished (with a '-') -traceCall :: String -> String -> (a -> String) -> a -> a - --- | showing the resulting value (filtered through a printing function): --- @{fun: value}@ -tracePrt :: String -> (a -> String) -> a -> a - --- | this is equivalent to 'seq' when tracing, but --- just skips the first argument otherwise -traceCalcFirst :: a -> b -> b - -#if TRACING -trace str a = Trace.trace (bold ++ "{" ++ normal ++ str ++ bold ++ "}" ++ normal) a -trace2 fun str a = trace (bold ++ fgcol 1 ++ fun ++ ": " ++ normal ++ str) a -traceM fun str = trace2 fun str (return ()) -traceCall fun start prt val - = trace2 ("+" ++ fun) start $ - val `seq` trace2 ("-" ++ fun) (prt val) val -tracePrt mod prt val = val `seq` trace2 mod (prt val) val -traceCalcFirst = seq - -#else -trace _ = id -trace2 _ _ = id -traceM _ _ = return () -traceCall _ _ _ = id -tracePrt _ _ = id -traceCalcFirst _ = id - -#endif - - -escape = "\ESC" -highlight = escape ++ "[7m" -bold = escape ++ "[1m" -underline = escape ++ "[4m" -normal = escape ++ "[0m" -fgcol col = escape ++ "[0" ++ show (30+col) ++ "m" -bgcol col = escape ++ "[0" ++ show (40+col) ++ "m" diff --git a/src-3.0/GF/System/UseReadline.hs b/src-3.0/GF/System/UseReadline.hs deleted file mode 100644 index c84b9d7f4..000000000 --- a/src-3.0/GF/System/UseReadline.hs +++ /dev/null @@ -1,25 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.UseReadline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Use GNU readline ------------------------------------------------------------------------------ - -module GF.System.UseReadline (fetchCommand) where - -import System.Console.Readline (readline, addHistory) - -fetchCommand :: String -> IO (String) -fetchCommand s = do - res <- readline s - case res of - Nothing -> return "q" - Just s -> do addHistory s - return s diff --git a/src-3.0/GF/System/UseSignal.hs b/src-3.0/GF/System/UseSignal.hs deleted file mode 100644 index 5e6d81237..000000000 --- a/src-3.0/GF/System/UseSignal.hs +++ /dev/null @@ -1,58 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.UseSignal --- Maintainer : Bjorn Bringert --- Stability : (stability) --- Portability : (portability) --- --- > CVS $Date: 2005/11/11 11:12:50 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Allows SIGINT (Ctrl-C) to interrupt computations. ------------------------------------------------------------------------------ - -module GF.System.UseSignal where - -import Control.Concurrent (myThreadId, killThread) -import Control.Exception (Exception,catch) -import Prelude hiding (catch) -import System.IO -import System.Posix.Signals - -{-# NOINLINE runInterruptibly #-} - --- | Run an IO action, and allow it to be interrupted --- by a SIGINT to the current process. Returns --- an exception if the process did not complete --- normally. --- NOTES: --- * This will replace any existing SIGINT --- handler during the action. After the computation --- has completed the existing handler will be restored. --- * If the IO action is lazy (e.g. using readFile, --- unsafeInterleaveIO etc.) the lazy computation will --- not be interruptible, as it will be performed --- after the signal handler has been removed. -runInterruptibly :: IO a -> IO (Either Exception a) -runInterruptibly a = - do t <- myThreadId - oldH <- installHandler sigINT (Catch (killThread t)) Nothing - x <- p `catch` h - installHandler sigINT oldH Nothing - return x - where p = a >>= \x -> return $! Right $! x - h e = return $ Left e - --- | Like 'runInterruptibly', but always returns (), whether --- the computation fails or not. -runInterruptibly_ :: IO () -> IO () -runInterruptibly_ = fmap (either (const ()) id) . runInterruptibly - --- | Run an action with SIGINT blocked. -blockInterrupt :: IO a -> IO a -blockInterrupt a = - do oldH <- installHandler sigINT Ignore Nothing - x <- a - installHandler sigINT oldH Nothing - return x diff --git a/src-3.0/GF/Text/Arabic.hs b/src-3.0/GF/Text/Arabic.hs deleted file mode 100644 index c482b1172..000000000 --- a/src-3.0/GF/Text/Arabic.hs +++ /dev/null @@ -1,63 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Arabic --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:34 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Arabic (mkArabic) where - -mkArabic :: String -> String -mkArabic = unwords . (map mkArabicWord) . words -----mkArabic = reverse . unwords . (map mkArabicWord) . words ---- reverse : assumes everything's on same line - -type ArabicChar = Char - -mkArabicWord :: String -> [ArabicChar] -mkArabicWord = map mkArabicChar . getLetterPos - -getLetterPos :: String -> [(Char,Int)] -getLetterPos [] = [] -getLetterPos ('I':cs) = ('*',7) : getLetterPos cs -- 0xfe80 -getLetterPos ('O':cs) = ('*',8) : getIn cs -- 0xfe8b -getLetterPos ('l':'a':cs) = ('*',5) : getLetterPos cs -- 0xfefb -getLetterPos [c] = [(c,1)] -- 1=isolated -getLetterPos (c:cs) | isReduced c = (c,1) : getLetterPos cs -getLetterPos (c:cs) = (c,3) : getIn cs -- 3=initial - - -getIn [] = [] -getIn ('I':cs) = ('*',7) : getLetterPos cs -- 0xfe80 -getIn ('O':cs) = ('*',9) : getIn cs -- 0xfe8c -getIn ('l':'a':cs) = ('*',6) : getLetterPos cs -- 0xfefc -getIn [c] = [(c,2)] -- 2=final -getIn (c:cs) | isReduced c = (c,2) : getLetterPos cs -getIn (c:cs) = (c,4) : getIn cs -- 4=medial - -isReduced :: Char -> Bool -isReduced c = c `elem` "UuWiYOaAdVrzwj" - -mkArabicChar ('*',p) | p > 4 && p < 10 = - (map toEnum [0xfefb,0xfefc,0xfe80,0xfe8b,0xfe8c]) !! (p-5) -mkArabicChar cp@(c,p) = case lookup c cc of Just c' -> (c' !! (p-1)) ; _ -> c - where - cc = mkArabicTab allArabicCodes allArabic - -mkArabicTab (c:cs) as = (c,as1) : mkArabicTab cs as2 where - (as1,as2) = if isReduced c then splitAt 2 as else splitAt 4 as -mkArabicTab [] _ = [] - -allArabicCodes = "UuWiYOabAtvgHCdVrzscSDTZoxfqklmnhwjy" - -allArabic :: String -allArabic = (map toEnum [0xfe81 .. 0xfef4]) -- I=0xfe80 - - diff --git a/src-3.0/GF/Text/Devanagari.hs b/src-3.0/GF/Text/Devanagari.hs deleted file mode 100644 index bf4343cd0..000000000 --- a/src-3.0/GF/Text/Devanagari.hs +++ /dev/null @@ -1,97 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Devanagari --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:34 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Devanagari (mkDevanagari) where - -mkDevanagari :: String -> String -mkDevanagari = digraphWordToUnicode . adHocToDigraphWord - -adHocToDigraphWord :: String -> [(Char, Char)] -adHocToDigraphWord str = case str of - [] -> [] - '<' : cs -> ('\\', '<') : spoolMarkup cs - ' ' : cs -> ('\\', ' ') : adHocToDigraphWord cs -- skip space - --- if c1 is a vowel - -- Two of the same vowel => lengthening - c1 : c2 : cs | c1 == c2 && isVowel c1 -> (cap c1, ':') : adHocToDigraphWord cs - -- digraphed or long vowel - c1 : c2 : cs | isVowel c1 && isVowel c2 -> (cap c1, cap c2) : adHocToDigraphWord cs - c1 : cs | isVowel c1 -> (' ', cap c1) : adHocToDigraphWord cs - --- c1 isn't a vowel - -- c1 : 'a' : [] -> [(' ', c1)] -- a inherent - -- c1 : c2 : [] | isVowel c2 -> (' ', c1) : [(' ', c2)] - - -- c1 is aspirated - c1 : 'H' : c2 : c3 : cs | c2 == c3 && isVowel c2 -> - (c1, 'H') : (c2, ':') : adHocToDigraphWord cs - c1 : 'H' : c2 : c3 : cs | isVowel c2 && isVowel c3 -> - (c1, 'H') : (c2, c3) : adHocToDigraphWord cs - c1 : 'H' : 'a' : cs -> (c1, 'H') : adHocToDigraphWord cs -- a inherent - c1 : 'H' : c2 : cs | isVowel c2 -> (c1, 'H') : (' ', c2) : adHocToDigraphWord cs - -- not vowelless at EOW - c1 : 'H' : ' ' : cs -> (c1, 'H') : ('\\', ' ') : adHocToDigraphWord cs - c1 : 'H' : [] -> [(c1, 'H')] - c1 : 'H' : cs -> (c1, 'H') : (' ', '^') : adHocToDigraphWord cs -- vowelless - - -- c1 unasp. - c1 : c2 : c3 : cs | c2 == c3 && isVowel c2 -> (' ', c1) : (c2, ':') : adHocToDigraphWord cs - c1 : c2 : c3 : cs | isVowel c2 && isVowel c3 -> (' ', c1) : (c2, c3) : adHocToDigraphWord cs - c1 : 'a' : cs -> (' ', c1) : adHocToDigraphWord cs -- a inherent - c1 : c2 : cs | isVowel c2 -> (' ', c1) : (' ', c2) : adHocToDigraphWord cs - -- not vowelless at EOW - c1 : ' ' : cs -> (' ', c1) : ('\\', ' '): adHocToDigraphWord cs - c1 : [] -> [(' ', c1)] - 'M' : cs -> (' ', 'M') : adHocToDigraphWord cs -- vowelless but no vowelless sign for anusvara - c1 : cs -> (' ', c1) : (' ', '^') : adHocToDigraphWord cs -- vowelless - -isVowel x = elem x "aeiou:" -cap :: Char -> Char -cap x = case x of - 'a' -> 'A' - 'e' -> 'E' - 'i' -> 'I' - 'o' -> 'O' - 'u' -> 'U' - c -> c - -spoolMarkup :: String -> [(Char, Char)] -spoolMarkup s = case s of - -- [] -> [] -- Shouldn't happen - '>' : cs -> ('\\', '>') : adHocToDigraphWord cs - c1 : cs -> ('\\', c1) : spoolMarkup cs - - -digraphWordToUnicode :: [(Char, Char)] -> String -digraphWordToUnicode = map digraphToUnicode - -digraphToUnicode :: (Char, Char) -> Char -digraphToUnicode (c1, c2) = case lookup (c1, c2) cc of Just c' -> c' ; _ -> c2 - where - cc = zip allDevanagariCodes allDevanagari - -digraphedDevanagari = " ~ M ;__ AA: II: UU:RoLoEvE~ EE:AvA~ OAU kkH ggHNG ccH jjH \241 TTH DDH N ttH ddH nn. ppH bbH m y rr. l LL. v \231 S s h____ .-Sa: ii: uu:ror:eve~ eaiava~ oau ^____OM | -dddu______ Q X G zD.RH fy.R:L:mrmR#I#d#0#1#2#3#4#5#6#7#8#9#o" - -allDevanagariCodes :: [(Char, Char)] -allDevanagariCodes = mkPairs digraphedDevanagari - -allDevanagari :: String -allDevanagari = (map toEnum [0x0901 .. 0x0970]) - -mkPairs :: String -> [(Char, Char)] -mkPairs str = case str of - [] -> [] - c1 : c2 : cs -> (c1, c2) : mkPairs cs - diff --git a/src-3.0/GF/Text/Ethiopic.hs b/src-3.0/GF/Text/Ethiopic.hs deleted file mode 100644 index 81abbf719..000000000 --- a/src-3.0/GF/Text/Ethiopic.hs +++ /dev/null @@ -1,72 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Ethiopic --- Maintainer : HH --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:35 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Ascii-Unicode decoding for Ethiopian. --- Copyright (c) Harald Hammarström 2003 under Gnu General Public License ------------------------------------------------------------------------------ - -module GF.Text.Ethiopic (mkEthiopic) where - -mkEthiopic :: String -> String -mkEthiopic = digraphWordToUnicode . adHocToDigraphWord - --- mkEthiopic :: String -> String --- mkEthiopic = reverse . unwords . (map (digraphWordToUnicode . adHocToDigraphWord)) . words ---- reverse : assumes everything's on same line - -adHocToDigraphWord :: String -> [(Char, Int)] -adHocToDigraphWord str = case str of - [] -> [] - '<' : cs -> ('<', -1) : spoolMarkup cs - c1 : cs | isVowel c1 -> (')', vowelOrder c1) : adHocToDigraphWord cs - -- c1 isn't a vowel - c1 : cs | not (elem c1 allEthiopicCodes) -> (c1, -1) : adHocToDigraphWord cs - c1 : c2 : cs | isVowel c2 -> (c1, vowelOrder c2) : adHocToDigraphWord cs - c1 : cs -> (c1, 5) : adHocToDigraphWord cs - -spoolMarkup :: String -> [(Char, Int)] -spoolMarkup s = case s of - -- [] -> [] -- Shouldn't happen - '>' : cs -> ('>', -1) : adHocToDigraphWord cs - c1 : cs -> (c1, -1) : spoolMarkup cs - -isVowel x = elem x "A\228ui\239aeoI" - -vowelOrder :: Char -> Int -vowelOrder x = case x of - 'A' -> 0 - '\228' -> 0 -- ä - 'u' -> 1 - 'i' -> 2 - 'a' -> 3 - 'e' -> 4 - 'I' -> 5 - '\239' -> 5 -- ï - 'o' -> 6 - c -> 5 -- vowelless - -digraphWordToUnicode = map digraphToUnicode - -digraphToUnicode :: (Char, Int) -> Char --- digraphToUnicode (c1, c2) = c1 - -digraphToUnicode (c1, -1) = c1 -digraphToUnicode (c1, c2) = toEnum (0x1200 + c2 + 8*case lookup c1 cc of Just c' -> c') - where - cc = zip allEthiopicCodes allEthiopic - -allEthiopic :: [Int] -allEthiopic = [0 .. 44] -- x 8 - -allEthiopicCodes = "hlHmLrs$KQ__bBtcxXnN)kW__w(zZyd_jgG_TCPSLfp" - --- Q = kW, X = xW, W = kW, G = gW - diff --git a/src-3.0/GF/Text/ExtendedArabic.hs b/src-3.0/GF/Text/ExtendedArabic.hs deleted file mode 100644 index d2c5faac5..000000000 --- a/src-3.0/GF/Text/ExtendedArabic.hs +++ /dev/null @@ -1,99 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ExtendedArabic --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:36 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.ExtendedArabic (mkArabic0600, mkExtendedArabic) where - -mkArabic0600 :: String -> String -mkArabic0600 = digraphWordToUnicode . aarnesToDigraphWord - -aarnesToDigraphWord :: String -> [(Char, Char)] -aarnesToDigraphWord str = case str of - [] -> [] - '<' : cs -> ('\\', '<') : spoolMarkup2 cs - - 'v' : cs -> ('T', 'H') : aarnesToDigraphWord cs - 'a' : cs -> (' ', 'A') : aarnesToDigraphWord cs - 'o' : cs -> (' ', '3') : aarnesToDigraphWord cs - 'O' : cs -> ('\'', 'i') : aarnesToDigraphWord cs - - 'u' : cs -> ('\'', 'A') : aarnesToDigraphWord cs - 'C' : cs -> (' ', 'X') : aarnesToDigraphWord cs - - 'U' : cs -> ('~', 'A') : aarnesToDigraphWord cs - 'A' : cs -> ('"', 't') : aarnesToDigraphWord cs - 'c' : cs -> ('s', 'h') : aarnesToDigraphWord cs - c : cs -> (' ', c) : aarnesToDigraphWord cs - -mkExtendedArabic :: String -> String -mkExtendedArabic = digraphWordToUnicode . adHocToDigraphWord - -adHocToDigraphWord :: String -> [(Char, Char)] -adHocToDigraphWord str = case str of - [] -> [] - '<' : cs -> ('\\', '<') : spoolMarkup cs - -- Sorani - 'W' : cs -> (':', 'w') : adHocToDigraphWord cs -- ?? Will do - 'E' : cs -> (' ', 'i') : adHocToDigraphWord cs -- ?? Letter missing! - 'j' : cs -> ('d', 'j') : adHocToDigraphWord cs - 'O' : cs -> ('v', 'w') : adHocToDigraphWord cs - 'F' : cs -> (' ', 'v') : adHocToDigraphWord cs - 'Z' : cs -> ('z', 'h') : adHocToDigraphWord cs - 'I' : cs -> (' ', 'i') : adHocToDigraphWord cs -- ?? Letter missing! - 'C' : cs -> ('c', 'h') : adHocToDigraphWord cs - -- Pashto - 'e' : cs -> (':', 'y') : adHocToDigraphWord cs - '$' : cs -> ('3', 'H') : adHocToDigraphWord cs - 'X' : cs -> ('s', '.') : adHocToDigraphWord cs - 'G' : cs -> ('z', '.') : adHocToDigraphWord cs - 'a' : cs -> (' ', 'A') : adHocToDigraphWord cs - 'P' : cs -> ('\'', 'H') : adHocToDigraphWord cs - 'R' : cs -> ('o', 'r') : adHocToDigraphWord cs - -- Shared - 'A' : cs -> (' ', 'h') : adHocToDigraphWord cs -- ?? Maybe to "t or 0x06d5 - 'c' : cs -> ('s', 'h') : adHocToDigraphWord cs - c : cs -> (' ', c) : adHocToDigraphWord cs - - --- Beginning 0x621 up and including 0x06d1 -digraphedExtendedArabic = " '~A'A'w,A'i A b\"t tTHdj H X dDH r z ssh S D T Z 3GH__________ - f q k l m n h w i y&a&w&i/a/w/i/W/o/~/'/,/|/6/v_____________#0#1#2#3#4#5#6#7#8#9#%#,#'#*>b>q$|> A2'2,3'A'w'w&y'Tb:b:BoT3b p4b4B'H:H2H\"H3Hch4HTdod.dTD:d:D3d3D4dTrvror.rvRz.:rzh4zs.+s*S:S3S3T33>ff.f: v4f.q3q-k~kok.k3k3K gog:g:G3Gvl.l3l3L:n>nTnon3n?h4H't>Y\"Yow-wvwww|w^w:w3w>y/yvy.w:y3y____ -ae" - -digraphWordToUnicode = map digraphToUnicode - -digraphToUnicode :: (Char, Char) -> Char -digraphToUnicode (c1, c2) = case lookup (c1, c2) cc of Just c' -> c' ; _ -> c2 - where - cc = zip allExtendedArabicCodes allExtendedArabic - -allExtendedArabicCodes :: [(Char, Char)] -allExtendedArabicCodes = mkPairs digraphedExtendedArabic - -allExtendedArabic :: String -allExtendedArabic = (map toEnum [0x0621 .. 0x06d1]) - -mkPairs :: String -> [(Char, Char)] -mkPairs str = case str of - [] -> [] - c1 : c2 : cs -> (c1, c2) : mkPairs cs - -spoolMarkup :: String -> [(Char, Char)] -spoolMarkup s = case s of - [] -> [] -- Shouldn't happen - '>' : cs -> ('\\', '>') : adHocToDigraphWord cs - c1 : cs -> ('\\', c1) : spoolMarkup cs - -spoolMarkup2 :: String -> [(Char, Char)] -spoolMarkup2 s = case s of - [] -> [] -- Shouldn't happen - '>' : cs -> ('\\', '>') : aarnesToDigraphWord cs - c1 : cs -> ('\\', c1) : spoolMarkup2 cs diff --git a/src-3.0/GF/Text/ExtraDiacritics.hs b/src-3.0/GF/Text/ExtraDiacritics.hs deleted file mode 100644 index f3d811c2c..000000000 --- a/src-3.0/GF/Text/ExtraDiacritics.hs +++ /dev/null @@ -1,37 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ExtraDiacritics --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:36 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.ExtraDiacritics (mkExtraDiacritics) where - -mkExtraDiacritics :: String -> String -mkExtraDiacritics = mkExtraDiacriticsWord - -mkExtraDiacriticsWord :: String -> String -mkExtraDiacriticsWord str = case str of - [] -> [] - '<' : cs -> '<' : spoolMarkup cs - -- - '/' : cs -> toEnum 0x0301 : mkExtraDiacriticsWord cs - '~' : cs -> toEnum 0x0306 : mkExtraDiacriticsWord cs - ':' : cs -> toEnum 0x0304 : mkExtraDiacriticsWord cs -- some of these could be put in LatinA - '.' : cs -> toEnum 0x0323 : mkExtraDiacriticsWord cs - 'i' : '-' : cs -> toEnum 0x0268 : mkExtraDiacriticsWord cs -- in IPA extensions - -- Default - c : cs -> c : mkExtraDiacriticsWord cs - -spoolMarkup :: String -> String -spoolMarkup s = case s of - [] -> [] -- Shouldn't happen - '>' : cs -> '>' : mkExtraDiacriticsWord cs - c1 : cs -> c1 : spoolMarkup cs diff --git a/src-3.0/GF/Text/Greek.hs b/src-3.0/GF/Text/Greek.hs deleted file mode 100644 index 6b9361a29..000000000 --- a/src-3.0/GF/Text/Greek.hs +++ /dev/null @@ -1,172 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Greek --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:37 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Greek (mkGreek) where - -mkGreek :: String -> String -mkGreek = unwords . (map mkGreekWord) . mkGravis . words - ---- TODO : optimize character formation by factorizing the case expressions - -type GreekChar = Char - -mkGreekWord :: String -> [GreekChar] -mkGreekWord = map (toEnum . mkGreekChar) . mkGreekSpec - -mkGravis :: [String] -> [String] -mkGravis [] = [] -mkGravis [w] = [w] -mkGravis (w1:w2:ws) - | stressed w2 = mkG w1 : mkGravis (w2:ws) - | otherwise = w1 : w2 : mkGravis ws - where - stressed w = any (`elem` "'~`") w - mkG :: String -> String - mkG w = let (w1,w2) = span (/='\'') w in - case w2 of - '\'':v:cs | not (any isVowel cs) -> w1 ++ "`" ++ [v] ++ cs - '\'':'!':v:cs | not (any isVowel cs) -> w1 ++ "`!" ++ [v] ++ cs - _ -> w - isVowel c = elem c "aehiouw" - -mkGreekSpec :: String -> [(Char,Int)] -mkGreekSpec str = case str of - [] -> [] - '(' :'\'': '!' : c : cs -> (c,25) : mkGreekSpec cs - '(' :'~' : '!' : c : cs -> (c,27) : mkGreekSpec cs - '(' :'`' : '!' : c : cs -> (c,23) : mkGreekSpec cs - '(' : '!' : c : cs -> (c,21) : mkGreekSpec cs - ')' :'\'': '!' : c : cs -> (c,24) : mkGreekSpec cs - ')' :'~' : '!' : c : cs -> (c,26) : mkGreekSpec cs - ')' :'`' : '!' : c : cs -> (c,22) : mkGreekSpec cs - ')' : '!' : c : cs -> (c,20) : mkGreekSpec cs - '\'': '!' : c : cs -> (c,30) : mkGreekSpec cs - '~' : '!' : c : cs -> (c,31) : mkGreekSpec cs - '`' : '!' : c : cs -> (c,32) : mkGreekSpec cs - '!' : c : cs -> (c,33) : mkGreekSpec cs - '(' :'\'': c : cs -> (c,5) : mkGreekSpec cs - '(' :'~' : c : cs -> (c,7) : mkGreekSpec cs - '(' :'`' : c : cs -> (c,3) : mkGreekSpec cs - '(' : c : cs -> (c,1) : mkGreekSpec cs - ')' :'\'': c : cs -> (c,4) : mkGreekSpec cs - ')' :'~' : c : cs -> (c,6) : mkGreekSpec cs - ')' :'`' : c : cs -> (c,2) : mkGreekSpec cs - ')' : c : cs -> (c,0) : mkGreekSpec cs - '\'': c : cs -> (c,10) : mkGreekSpec cs - '~' : c : cs -> (c,11) : mkGreekSpec cs - '`' : c : cs -> (c,12) : mkGreekSpec cs - c : cs -> (c,-1) : mkGreekSpec cs - -mkGreekChar (c,-1) = case lookup c cc of Just c' -> c' ; _ -> fromEnum c - where - cc = zip "abgdezhqiklmnxoprjstyfcuw" allGreekMin -mkGreekChar (c,n) = case (c,n) of - ('a',10) -> 0x03ac - ('a',11) -> 0x1fb6 - ('a',12) -> 0x1f70 - ('a',30) -> 0x1fb4 - ('a',31) -> 0x1fb7 - ('a',32) -> 0x1fb2 - ('a',33) -> 0x1fb3 - ('a',n) | n >19 -> 0x1f80 + n - 20 - ('a',n) -> 0x1f00 + n - ('e',10) -> 0x03ad -- ' --- ('e',11) -> 0x1fb6 -- ~ can't happen - ('e',12) -> 0x1f72 -- ` - ('e',n) -> 0x1f10 + n - ('h',10) -> 0x03ae -- ' - ('h',11) -> 0x1fc6 -- ~ - ('h',12) -> 0x1f74 -- ` - - ('h',30) -> 0x1fc4 - ('h',31) -> 0x1fc7 - ('h',32) -> 0x1fc2 - ('h',33) -> 0x1fc3 - ('h',n) | n >19 -> 0x1f90 + n - 20 - - ('h',n) -> 0x1f20 + n - ('i',10) -> 0x03af -- ' - ('i',11) -> 0x1fd6 -- ~ - ('i',12) -> 0x1f76 -- ` - ('i',n) -> 0x1f30 + n - ('o',10) -> 0x03cc -- ' --- ('o',11) -> 0x1fb6 -- ~ can't happen - ('o',12) -> 0x1f78 -- ` - ('o',n) -> 0x1f40 + n - ('y',10) -> 0x03cd -- ' - ('y',11) -> 0x1fe6 -- ~ - ('y',12) -> 0x1f7a -- ` - ('y',n) -> 0x1f50 + n - ('w',10) -> 0x03ce -- ' - ('w',11) -> 0x1ff6 -- ~ - ('w',12) -> 0x1f7c -- ` - - ('w',30) -> 0x1ff4 - ('w',31) -> 0x1ff7 - ('w',32) -> 0x1ff2 - ('w',33) -> 0x1ff3 - ('w',n) | n >19 -> 0x1fa0 + n - 20 - - ('w',n) -> 0x1f60 + n - ('r',1) -> 0x1fe5 - _ -> mkGreekChar (c,-1) --- should not happen - -allGreekMin :: [Int] -allGreekMin = [0x03b1 .. 0x03c9] - - -{- -encoding of Greek writing. Those hard to guess are marked with --- - - maj min -A a Alpha 0391 03b1 -B b Beta 0392 03b2 -G g Gamma 0393 03b3 -D d Delta 0394 03b4 -E e Epsilon 0395 03b5 -Z z Zeta 0396 03b6 -H h Eta --- 0397 03b7 -Q q Theta --- 0398 03b8 -I i Iota 0399 03b9 -K k Kappa 039a 03ba -L l Lambda 039b 03bb -M m My 039c 03bc -N n Ny 039d 03bd -X x Xi 039e 03be -O o Omikron 039f 03bf -P p Pi 03a0 03c0 -R r Rho 03a1 03c1 - j Sigma --- 03c2 -S s Sigma 03a3 03c3 -T t Tau 03a4 03c4 -Y y Ypsilon 03a5 03c5 -F f Phi 03a6 03c6 -C c Khi --- 03a7 03c7 -U u Psi 03a8 03c8 -W w Omega --- 03a9 03c9 - -( spiritus asper -) spiritus lenis -! iota subscriptum - -' acutus -~ circumflexus -` gravis - --} - - - - - diff --git a/src-3.0/GF/Text/Hebrew.hs b/src-3.0/GF/Text/Hebrew.hs deleted file mode 100644 index c7026d8da..000000000 --- a/src-3.0/GF/Text/Hebrew.hs +++ /dev/null @@ -1,53 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Hebrew --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:37 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Hebrew (mkHebrew) where - -mkHebrew :: String -> String -mkHebrew = mkHebrewWord -----mkHebrew = reverse . mkHebrewWord ---- reverse : assumes everything's on same line - -type HebrewChar = Char - --- HH 031103 added code for spooling the markup --- removed reverse, words, unwords --- (seemed obsolete and come out wrong on the screen) --- AR 26/1/2004 put reverse back - needed in Fudgets (but not in Java?) - -mkHebrewWord :: String -> [HebrewChar] --- mkHebrewWord = map mkHebrewChar - -mkHebrewWord s = case s of - [] -> [] - '<' : cs -> '<' : spoolMarkup cs - ' ' : cs -> ' ' : mkHebrewWord cs - c1 : cs -> mkHebrewChar c1 : mkHebrewWord cs - -spoolMarkup :: String -> String -spoolMarkup s = case s of - [] -> [] -- Shouldn't happen - '>' : cs -> '>' : mkHebrewWord cs - c1 : cs -> c1 : spoolMarkup cs - -mkHebrewChar c = case lookup c cc of Just c' -> c' ; _ -> c - where - cc = zip allHebrewCodes allHebrew - -allHebrewCodes = "-abgdhwzHTyKklMmNnSoPpCcqrst" - -allHebrew :: String -allHebrew = (map toEnum (0x05be : [0x05d0 .. 0x05ea])) - - diff --git a/src-3.0/GF/Text/Hiragana.hs b/src-3.0/GF/Text/Hiragana.hs deleted file mode 100644 index ba74fc83c..000000000 --- a/src-3.0/GF/Text/Hiragana.hs +++ /dev/null @@ -1,95 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Hiragana --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:38 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Hiragana (mkJapanese) where - --- long vowel romaaji must be ei, ou not ee, oo - -mkJapanese :: String -> String -mkJapanese = digraphWordToUnicode . romaajiToDigraphWord - -romaajiToDigraphWord :: String -> [(Char, Char)] -romaajiToDigraphWord str = case str of - [] -> [] - '<' : cs -> ('\\', '<') : spoolMarkup cs - ' ' : cs -> ('\\', ' ') : romaajiToDigraphWord cs - - c1 : cs | isVowel c1 -> (' ', cap c1) : romaajiToDigraphWord cs - - -- The combinations - c1 : 'y' : c2 : cs -> (c1, 'i') : ('y', cap c2) : romaajiToDigraphWord cs - - 's' : 'h' : 'a' : cs -> ('S', 'i') : ('y', 'A') : romaajiToDigraphWord cs - 'c' : 'h' : 'a' : cs -> ('C', 'i') : ('y', 'A') : romaajiToDigraphWord cs - 'j' : 'a' : cs -> ('j', 'i') : ('y', 'A') : romaajiToDigraphWord cs - - 's' : 'h' : 'u' : cs -> ('S', 'i') : ('y', 'U') : romaajiToDigraphWord cs - 'c' : 'h' : 'u' : cs -> ('C', 'i') : ('y', 'U') : romaajiToDigraphWord cs - 'j' : 'u' : cs -> ('j', 'i') : ('y', 'U') : romaajiToDigraphWord cs - - 's' : 'h' : 'o' : cs -> ('S', 'i') : ('y', 'O') : romaajiToDigraphWord cs - 'c' : 'h' : 'o' : cs -> ('C', 'i') : ('y', 'O') : romaajiToDigraphWord cs - 'j' : 'o' : cs -> ('j', 'i') : ('y', 'O') : romaajiToDigraphWord cs - - 'd' : 'z' : c3 : cs -> ('D', c3) : romaajiToDigraphWord cs - 't' : 's' : c3 : cs -> ('T', c3) : romaajiToDigraphWord cs - 'c' : 'h' : c3 : cs -> ('C', c3) : romaajiToDigraphWord cs - 's' : 'h' : c3 : cs -> ('S', c3) : romaajiToDigraphWord cs - 'z' : 'h' : c3 : cs -> ('Z', c3) : romaajiToDigraphWord cs - - c1 : ' ' : cs -> (' ', c1) : ('\\', ' ') : romaajiToDigraphWord cs -- n - c1 : [] -> [(' ', c1)] -- n - - c1 : c2 : cs | isVowel c2 -> (c1, c2) : romaajiToDigraphWord cs - c1 : c2 : cs | c1 == c2 -> ('T', 'U') : romaajiToDigraphWord (c2 : cs) -- double cons - c1 : cs -> (' ', c1) : romaajiToDigraphWord cs -- n - -isVowel x = elem x "aeiou" -cap :: Char -> Char -cap x = case x of - 'a' -> 'A' - 'e' -> 'E' - 'i' -> 'I' - 'o' -> 'O' - 'u' -> 'U' - c -> c - -spoolMarkup :: String -> [(Char, Char)] -spoolMarkup s = case s of - -- [] -> [] -- Shouldn't happen - '>' : cs -> ('\\', '>') : romaajiToDigraphWord cs - c1 : cs -> ('\\', c1) : spoolMarkup cs - -digraphWordToUnicode :: [(Char, Char)] -> String -digraphWordToUnicode = map digraphToUnicode - -digraphToUnicode :: (Char, Char) -> Char -digraphToUnicode (c1, c2) = case lookup (c1, c2) cc of Just c' -> c' ; _ -> c2 - where - cc = zip allHiraganaCodes allHiragana - -allHiraganaCodes :: [(Char, Char)] -allHiraganaCodes = mkPairs digraphedHiragana - -allHiragana :: String -allHiragana = (map toEnum [0x3041 .. 0x309f]) - -mkPairs :: String -> [(Char, Char)] -mkPairs str = case str of - [] -> [] - c1 : c2 : cs -> (c1, c2) : mkPairs cs - -digraphedHiragana = " a A i I u U e E o OkagakigikugukegekogosazaSiZisuzusezesozotadaCijiTUTuDutedetodonaninunenohabapahibipihubupuhebepehobopomamimumemoyAyayUyuyOyorarirurerowaWawiwewo nvukAkE____<< o>>o >'> b" - - diff --git a/src-3.0/GF/Text/LatinASupplement.hs b/src-3.0/GF/Text/LatinASupplement.hs deleted file mode 100644 index f42423c91..000000000 --- a/src-3.0/GF/Text/LatinASupplement.hs +++ /dev/null @@ -1,69 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : LatinASupplement --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:39 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.LatinASupplement (mkLatinASupplement) where - -mkLatinASupplement :: String -> String -mkLatinASupplement = mkLatinASupplementWord - -mkLatinASupplementWord :: String -> String -mkLatinASupplementWord str = case str of - [] -> [] - '<' : cs -> '<' : spoolMarkup cs - -- Romanian & partly Turkish - 's' : ',' : cs -> toEnum 0x015f : mkLatinASupplementWord cs - 'a' : '%' : cs -> toEnum 0x0103 : mkLatinASupplementWord cs - -- Slavic and more - 'c' : '^' : cs -> toEnum 0x010d : mkLatinASupplementWord cs - 's' : '^' : cs -> toEnum 0x0161 : mkLatinASupplementWord cs - 'c' : '\'' : cs -> toEnum 0x0107 : mkLatinASupplementWord cs - 'z' : '^' : cs -> toEnum 0x017e : mkLatinASupplementWord cs - -- Turkish - 'g' : '%' : cs -> toEnum 0x011f : mkLatinASupplementWord cs - 'I' : cs -> toEnum 0x0131 : mkLatinASupplementWord cs - 'c' : ',' : cs -> toEnum 0x00e7 : mkLatinASupplementWord cs - -- Polish - 'e' : ',' : cs -> toEnum 0x0119 : mkLatinASupplementWord cs - 'a' : ',' : cs -> toEnum 0x0105 : mkLatinASupplementWord cs - 'l' : '/' : cs -> toEnum 0x0142 : mkLatinASupplementWord cs - 'z' : '.' : cs -> toEnum 0x017c : mkLatinASupplementWord cs - 'n' : '\'' : cs -> toEnum 0x0144 : mkLatinASupplementWord cs - 's' : '\'' : cs -> toEnum 0x015b : mkLatinASupplementWord cs --- 'c' : '\'' : cs -> toEnum 0x0107 : mkLatinASupplementWord cs - - -- Hungarian - 'o' : '%' : cs -> toEnum 0x0151 : mkLatinASupplementWord cs - 'u' : '%' : cs -> toEnum 0x0171 : mkLatinASupplementWord cs - - -- Mongolian - 'j' : '^' : cs -> toEnum 0x0135 : mkLatinASupplementWord cs - - -- Khowar (actually in Combining diacritical marks not Latin-A Suppl.) - 'o' : '.' : cs -> 'o' : (toEnum 0x0323 : mkLatinASupplementWord cs) - - -- Length bars over vowels e.g korean - 'a' : ':' : cs -> toEnum 0x0101 : mkLatinASupplementWord cs - 'e' : ':' : cs -> toEnum 0x0113 : mkLatinASupplementWord cs - 'i' : ':' : cs -> toEnum 0x012b : mkLatinASupplementWord cs - 'o' : ':' : cs -> toEnum 0x014d : mkLatinASupplementWord cs - 'u' : ':' : cs -> toEnum 0x016b : mkLatinASupplementWord cs - - -- Default - c : cs -> c : mkLatinASupplementWord cs - -spoolMarkup :: String -> String -spoolMarkup s = case s of - [] -> [] -- Shouldn't happen - '>' : cs -> '>' : mkLatinASupplementWord cs - c1 : cs -> c1 : spoolMarkup cs diff --git a/src-3.0/GF/Text/OCSCyrillic.hs b/src-3.0/GF/Text/OCSCyrillic.hs deleted file mode 100644 index 0d4696944..000000000 --- a/src-3.0/GF/Text/OCSCyrillic.hs +++ /dev/null @@ -1,47 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:39 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.OCSCyrillic (mkOCSCyrillic) where - -mkOCSCyrillic :: String -> String -mkOCSCyrillic = mkOCSCyrillicWord - -mkOCSCyrillicWord :: String -> String -mkOCSCyrillicWord str = case str of - [] -> [] - ' ' : cs -> ' ' : mkOCSCyrillicWord cs - '<' : cs -> '<' : spoolMarkup cs - '\228' : cs -> toEnum 0x0463 : mkOCSCyrillicWord cs -- ä - 'j' : 'e' : '~' : cs -> toEnum 0x0469 : mkOCSCyrillicWord cs - 'j' : 'o' : '~' : cs -> toEnum 0x046d : mkOCSCyrillicWord cs - 'j' : 'e' : cs -> toEnum 0x0465 : mkOCSCyrillicWord cs - 'e' : '~' : cs -> toEnum 0x0467 : mkOCSCyrillicWord cs - 'o' : '~' : cs -> toEnum 0x046b : mkOCSCyrillicWord cs - 'j' : 'u' : cs -> toEnum 0x044e : mkOCSCyrillicWord cs - 'j' : 'a' : cs -> toEnum 0x044f : mkOCSCyrillicWord cs - 'u' : cs -> toEnum 0x0479 : mkOCSCyrillicWord cs - c : cs -> (mkOCSCyrillicChar c) : mkOCSCyrillicWord cs - -spoolMarkup :: String -> String -spoolMarkup s = case s of - [] -> [] -- Shouldn't happen - '>' : cs -> '>' : mkOCSCyrillicWord cs - c1 : cs -> c1 : spoolMarkup cs - -mkOCSCyrillicChar :: Char -> Char -mkOCSCyrillicChar c = case lookup c cc of Just c' -> c' ; _ -> c - where - cc = zip "abvgdeZziJklmnoprstYfxCqwWUyIE" allOCSCyrillic - -allOCSCyrillic :: String -allOCSCyrillic = (map toEnum [0x0430 .. 0x044e]) diff --git a/src-3.0/GF/Text/Russian.hs b/src-3.0/GF/Text/Russian.hs deleted file mode 100644 index c4f1bfd89..000000000 --- a/src-3.0/GF/Text/Russian.hs +++ /dev/null @@ -1,56 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Russian --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:40 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Russian (mkRussian, mkRusKOI8) where - --- | an ad hoc ASCII encoding. Delimiters: @\/_ _\/@ -mkRussian :: String -> String -mkRussian = unwords . (map mkRussianWord) . words - --- | the KOI8 encoding, incomplete. Delimiters: @\/* *\/@ -mkRusKOI8 :: String -> String -mkRusKOI8 = unwords . (map mkRussianKOI8) . words - -type RussianChar = Char - -mkRussianWord :: String -> [RussianChar] -mkRussianWord = map (mkRussianChar allRussianCodes) - -mkRussianKOI8 :: String -> [RussianChar] -mkRussianKOI8 = map (mkRussianChar allRussianKOI8) - -mkRussianChar chars c = case lookup c cc of Just c' -> c' ; _ -> c - where - cc = zip chars allRussian - -allRussianCodes :: [Char] -allRussianCodes = - -- changed to Ints to work with Haskell compilers e.g. GHC 6.5 CVS - -- which expect source files to be in UTF-8 - -- /bringert 2006-05-19 - -- "ÅåABVGDEXZIJKLMNOPRSTUFHCQW£}!*ÖYÄabvgdexzijklmnoprstufhcqw#01'öyä" - map toEnum [197,229,65,66,86,71,68,69,88,90,73,74,75,76,77,78,79,80,82,83,84,85,70,72,67,81,87,163,125,33,42,214,89,196,97,98,118,103,100,101,120,122,105,106,107,108,109,110,111,112,114,115,116,117,102,104,99,113,119,35,48,49,39,246,121,228] - -allRussianKOI8 :: [Char] -allRussianKOI8 = - -- changed to Ints to work with Haskell compilers e.g. GHC 6.5 CVS - -- which expect source files to be in UTF-8 - -- /bringert 2006-05-19 - -- "^@áâ÷çäåöúéêëìíîïðòóôõæèãþûýøùÿüàñÁÂ×ÇÄÅÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝØÙßÜÀÑ" - map toEnum [94,64,225,226,247,231,228,229,246,250,233,234,235,236,237,238,239,240,242,243,244,245,230,232,227,254,251,253,248,249,255,252,224,241,193,194,215,199,196,197,214,218,201,202,203,204,205,206,207,208,210,211,212,213,198,200,195,222,219,221,216,217,223,220,192,209] - -allRussian :: String -allRussian = (map toEnum (0x0401:0x0451:[0x0410 .. 0x044f])) -- Ëë in odd places - - diff --git a/src-3.0/GF/Text/Tamil.hs b/src-3.0/GF/Text/Tamil.hs deleted file mode 100644 index 8ee171acf..000000000 --- a/src-3.0/GF/Text/Tamil.hs +++ /dev/null @@ -1,77 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Tamil --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:40 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Text.Tamil (mkTamil) where - -mkTamil :: String -> String -mkTamil = digraphWordToUnicode . adHocToDigraphWord - -adHocToDigraphWord :: String -> [(Char, Char)] -adHocToDigraphWord str = case str of - [] -> [] - '<' : cs -> ('\\', '<') : spoolMarkup cs - ' ' : cs -> ('\\', ' ') : adHocToDigraphWord cs -- skip space - --- if c1 is a vowel - -- Two of the same vowel => lengthening - c1 : c2 : cs | c1 == c2 && isVowel c1 -> (cap c1, ':') : adHocToDigraphWord cs - -- digraphed or long vowel - c1 : c2 : cs | isVowel c1 && isVowel c2 -> (cap c1, cap c2) : adHocToDigraphWord cs - c1 : cs | isVowel c1 -> (' ', cap c1) : adHocToDigraphWord cs - --- c1 isn't a vowel - c1 : c2 : c3 : cs | c2 == c3 && isVowel c2 -> (' ', c1) : (c2, ':') : adHocToDigraphWord cs - c1 : c2 : c3 : cs | isVowel c2 && isVowel c3 -> (' ', c1) : (c2, c3) : adHocToDigraphWord cs - c1 : 'a' : cs -> (' ', c1) : adHocToDigraphWord cs -- a inherent - c1 : c2 : cs | isVowel c2 -> (' ', c1) : (' ', c2) : adHocToDigraphWord cs - - c1 : cs -> (' ', c1) : (' ', '.') : adHocToDigraphWord cs -- vowelless - -isVowel x = elem x "aeiou:" -cap :: Char -> Char -cap x = case x of - 'a' -> 'A' - 'e' -> 'E' - 'i' -> 'I' - 'o' -> 'O' - 'u' -> 'U' - c -> c - -spoolMarkup :: String -> [(Char, Char)] -spoolMarkup s = case s of - -- [] -> [] -- Shouldn't happen - '>' : cs -> ('\\', '>') : adHocToDigraphWord cs - c1 : cs -> ('\\', c1) : spoolMarkup cs - -digraphWordToUnicode :: [(Char, Char)] -> String -digraphWordToUnicode = map digraphToUnicode - -digraphToUnicode :: (Char, Char) -> Char -digraphToUnicode (c1, c2) = case lookup (c1, c2) cc of Just c' -> c' ; _ -> c2 - where - cc = zip allTamilCodes allTamil - -mkPairs :: String -> [(Char, Char)] -mkPairs str = case str of - [] -> [] - c1 : c2 : cs -> (c1, c2) : mkPairs cs - -allTamilCodes :: [(Char, Char)] -allTamilCodes = mkPairs digraphedTamil - -allTamil :: String -allTamil = (map toEnum [0x0b85 .. 0x0bfa]) - -digraphedTamil = " AA: II: UU:______ EE:AI__ OO:AU k______ G c__ j__ \241 T______ N t______ V n p______ m y r l L M v__ s S h________a: ii: uu:______ ee:ai__ oo:au .__________________ :______________________________#1#2#3#4#5#6#7#8#9^1^2^3=d=m=y=d=c==ru##" - diff --git a/src-3.0/GF/Text/Text.hs b/src-3.0/GF/Text/Text.hs deleted file mode 100644 index b55355c20..000000000 --- a/src-3.0/GF/Text/Text.hs +++ /dev/null @@ -1,149 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Text --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/23 14:32:44 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.10 $ --- --- elementary text postprocessing. AR 21\/11\/2001. --- --- This is very primitive indeed. The functions should work on --- token lists and not on strings. AR 5\/12\/2002 --- --- XML hack 14\/8\/2004; not in use yet ------------------------------------------------------------------------------ - -module GF.Text.Text (untokWithXML, - exceptXML, - formatAsTextLit, - formatAsCodeLit, - formatAsText, - formatAsHTML, - formatAsLatex, - formatAsCode, - performBinds, - performBindsFinnish, - unStringLit, - concatRemSpace - ) where - -import GF.Data.Operations -import Data.Char - --- | does not apply untokenizer within XML tags --- heuristic "< " --- this function is applied from top level... -untokWithXML :: (String -> String) -> String -> String -untokWithXML unt s = case s of - '<':cs@(c:_) | isAlpha c -> '<':beg ++ ">" ++ unto (drop 1 rest) where - (beg,rest) = span (/='>') cs - '<':cs -> '<':unto cs --- - [] -> [] - _ -> unt beg ++ unto rest where - (beg,rest) = span (/='<') s - where - unto = untokWithXML unt - --- | ... whereas this one is embedded on a branch -exceptXML :: (String -> String) -> String -> String -exceptXML unt s = '<':beg ++ ">" ++ unt (drop 1 rest) where - (beg,rest) = span (/='>') s - -formatAsTextLit :: String -> String -formatAsTextLit = formatAsText . unwords . map unStringLit . words ---- hope that there will be deforestation... - -formatAsCodeLit :: String -> String -formatAsCodeLit = formatAsCode . unwords . map unStringLit . words - -formatAsText,formatAsHTML,formatAsLatex :: String -> String -formatAsText = formatAsTextGen (const False) (=="&-") -formatAsHTML = formatAsTextGen (\s -> take 1 s == "<" || last s == '>') (const False) -formatAsLatex = formatAsTextGen ((=="\\") . take 1) (const False) - -formatAsTextGen :: (String -> Bool) -> (String -> Bool) -> String -> String -formatAsTextGen tag para = unwords . format . cap . words where - format ws = case ws of - w : ww | capit w -> format $ (cap ww) - w : c : ww | major c -> format $ (w ++ c) :(cap ww) - w : c : ww | minor c -> format $ (w ++ c) : ww - p : c : ww | openp p -> format $ (p ++ c) :ww - p : c : ww | spanish p -> format $ (p ++ concat (cap [c])) :ww - c : ww | para c -> "\n\n" : format ww - w : ww -> w : format ww - [] -> [] - cap (p:ww) | tag p = p : cap ww - cap ((c:cs):ww) = (toUpper c : cs) : ww - cap [] = [] - capit = (=="&|") - major = flip elem (map singleton ".!?") - minor = flip elem (map singleton ",:;)") - openp = all (flip elem "(") - spanish = all (flip elem "\161\191") - -formatAsCode :: String -> String -formatAsCode = rend 0 . words where - -- render from BNF Converter - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - "{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts - "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts - "}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts - ";" :ts -> cons ";" $ new i $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - cons s t = s ++ t - new i s = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s - space t s = if null s then t else t ++ " " ++ s - -performBinds :: String -> String -performBinds = performBindsOpt (\x y -> y) - - --- The function defines an effect of the former on the latter part, --- such as in vowel harmony. It is triggered by the binder token "&*" - -performBindsOpt :: (String -> String -> String) -> String -> String -performBindsOpt harm = unwords . format . words where - format ws = case ws of - w : "&+" : u : ws -> format ((w ++ u) : ws) - w : "&*" : u : ws -> format ((w ++ harm w u) : ws) - w : ws -> w : format ws - [] -> [] - --- unlexer for Finnish particles --- Notice: left associativity crucial for "tie &* ko &* han" --> "tieköhän" - -performBindsFinnish :: String -> String -performBindsFinnish = performBindsOpt vowelHarmony where - vowelHarmony w p = if any (flip elem "aouAOU") w then p else map toFront p - toFront c = case c of - 'A' -> '\196' - 'O' -> '\214' - 'a' -> '\228' - 'o' -> '\246' - _ -> c - -unStringLit :: String -> String -unStringLit s = case s of - c : cs | strlim c && strlim (last cs) -> init cs - _ -> s - where - strlim = (=='\'') - -concatRemSpace :: String -> String -concatRemSpace = concat . words -{- -concatRemSpace s = case s of - '<':cs -> exceptXML concatRemSpace cs - c : cs | isSpace c -> concatRemSpace cs - c :cs -> c : concatRemSpace cs - _ -> s --} diff --git a/src-3.0/GF/Text/Thai.hs b/src-3.0/GF/Text/Thai.hs deleted file mode 100644 index 1b186cb3a..000000000 --- a/src-3.0/GF/Text/Thai.hs +++ /dev/null @@ -1,368 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Thai --- Maintainer : (Maintainer) --- Stability : (experimental) --- Portability : (portable) --- --- --- Thai transliteration and other alphabet information. ------------------------------------------------------------------------------ - --- AR 27/12/2006. Execute test2 to see the transliteration table. - -module GF.Text.Thai ( - mkThai,mkThaiWord,mkThaiPron,mkThaiFake,thaiFile,thaiPronFile,thaiFakeFile - ) where - -import qualified Data.Map as Map -import Data.Char - --- for testing -import GF.Text.UTF8 -import Data.List - -import Debug.Trace - - -mkThai :: String -> String -mkThai = concat . map mkThaiWord . words -mkThaiPron = unwords . map mkPronSyllable . words -mkThaiFake = unwords . map (fakeEnglish . mkPronSyllable) . words - - -type ThaiChar = Char - -mkThaiWord :: String -> [ThaiChar] -mkThaiWord = map (toEnum . mkThaiChar) . unchar . snd . pronAndOrth - -mkThaiChar :: String -> Int -mkThaiChar c = maybe 0 id $ Map.lookup c thaiMap - -thaiMap :: Map.Map String Int -thaiMap = Map.fromList $ zip allThaiTrans allThaiCodes - --- convert all string literals in a text - -thaiStrings :: String -> String -thaiStrings = convStrings mkThai - -thaiPronStrings :: String -> String -thaiPronStrings = convStrings mkThaiPron - -convStrings conv s = case s of - '"':cs -> let (t,_:r) = span (/='"') cs in - '"': conv t ++ "\"" ++ convStrings conv r - c:cs -> c : convStrings conv cs - _ -> s - - --- each character is either [letter] or [letter+nonletter] - -unchar :: String -> [String] -unchar s = case s of - c:d:cs - | isAlpha d -> [c] : unchar (d:cs) - | d == '?' -> unchar cs -- use "o?" to represent implicit 'o' - | otherwise -> [c,d] : unchar cs - [_] -> [s] - _ -> [] - --- you can prefix transliteration by irregular phonology in [] - -pronAndOrth :: String -> (Maybe String, String) -pronAndOrth s = case s of - '[':cs -> case span (/=']') cs of - (p,_:o) -> (Just p,o) - _ -> (Nothing,s) - _ -> (Nothing,s) - -allThaiTrans :: [String] -allThaiTrans = words $ - "- k k1 - k2 - k3 g c c1 c2 s' c3 y' d' t' " ++ - "t1 t2 t3 n' d t t4 t5 t6 n b p p1 f p2 f' " ++ - "p3 m y r - l - w s- s. s h l' O h' - " ++ - "a. a a: a+ i i: v v: u u: - - - - - - " ++ - "e e' o: a% a& L R S T1 T2 T3 T4 K - - - " ++ - "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 - - - - - - " - -allThaiCodes :: [Int] -allThaiCodes = [0x0e00 .. 0x0e7f] - - ---------------------- --- heuristic pronunciation of codes ---------------------- - --- fake English for TTS, a la Teach Yourself Thai - -fakeEnglish :: String -> String -fakeEnglish s = case s of - 'a':'a':cs -> "ah" ++ fakeEnglish cs - 'a':'y':cs -> "ai" ++ fakeEnglish cs - 'a' :cs -> "ah" ++ fakeEnglish cs - 'c':'h':cs -> "ch" ++ fakeEnglish cs - 'c' :cs -> "j" ++ fakeEnglish cs - 'e':'e':cs -> "aih" ++ fakeEnglish cs - 'g' :cs -> "ng" ++ fakeEnglish cs - 'i':'i':cs -> "ee" ++ fakeEnglish cs - 'k':'h':cs -> "k" ++ fakeEnglish cs - 'k' :cs -> "g" ++ fakeEnglish cs - 'O':'O':cs -> "or" ++ fakeEnglish cs - 'O' :cs -> "or" ++ fakeEnglish cs - 'o':'o':cs -> "or" ++ fakeEnglish cs - 'p':'h':cs -> "p" ++ fakeEnglish cs - 'p' :cs -> "b" ++ fakeEnglish cs - 't':'h':cs -> "t" ++ fakeEnglish cs - 't' :cs -> "d" ++ fakeEnglish cs - 'u':'u':cs -> "oo" ++ fakeEnglish cs - 'u' :cs -> "oo" ++ fakeEnglish cs - 'v':'v':cs -> "eu" ++ fakeEnglish cs - 'v' :cs -> "eu" ++ fakeEnglish cs - '\228':'\228':cs -> "air" ++ fakeEnglish cs - '\228' :cs -> "a" ++ fakeEnglish cs - '\246':'\246':cs -> "er" ++ fakeEnglish cs - '\246' :cs -> "er" ++ fakeEnglish cs - c:cs | isTone c -> fakeEnglish cs - c:cs -> c : fakeEnglish cs - _ -> s - where - isTone = flip elem "'`^~" - - --- this works for one syllable - -mkPronSyllable s = case fst $ pronAndOrth s of - Just p -> p - _ -> pronSyllable $ getSyllable $ map mkThaiChar $ unchar s - -data Syllable = Syll { - initv :: [Int], - initc :: [Int], - midv :: [Int], - finalc :: [Int], - finalv :: [Int], - tone :: [Int], - shorten :: Bool, - kill :: Bool - } - deriving Show - -data Tone = TMid | TLow | THigh | TRise | TFall - deriving Show - -data CClass = CLow | CMid | CHigh - deriving Show - -pronSyllable :: Syllable -> String -pronSyllable s = - initCons ++ tonem ++ vowel ++ finalCons - where - - vowel = case (initv s, midv s, finalv s, finalc s, shorten s, tone s) of - ([0x0e40],[0x0e35],_,[0x0e22],_,_) -> "ia" -- e-i:y - ([0x0e40],[0x0e2d,0x0e35],_,_,_,_) -> "va" -- e-i:O - ([0x0e40],[0x0e30,0x0e35],_,[0x0e22],_,_) -> "ia" -- e-i:ya. - ([0x0e40],[0x0e30,0x0e2d],_,_,_,_) -> "\246" -- e-Oa. - ([0x0e40],[0x0e30,0x0e32],_,_,_,_) -> "O" -- e-a:a. -- open o - ([0x0e40],[0x0e2d],_,_,_,_) -> "\246\246" -- e-O - ([0x0e40],[0x0e34],_,_,_,_) -> "\246\246" -- e-i - ([0x0e40],[0x0e30],_,_,_,_) -> "e" -- e-a. - ([0x0e40],[0x0e32],_,_,_,_) -> "aw" -- e-a: - ([0x0e40],[],[],[0x0e22],_,_) -> "\246\246y" -- e-y - ([0x0e40],[],[],_,True,_) -> "e" - - ([0x0e41],[0x0e30],_,_,_,_) -> "\228" -- ä-a. - ([0x0e41],[],[],_,True,_) -> "\228" - - ([0x0e42],[0x0e30],_,_,_,_) -> "o" -- o:-a. - - ([],[0x0e2d],_,[0x0e22],_,_) -> "OOy" -- Oy - ([],[0x0e2d],_,_,_,_) -> "OO" -- O - - ([],[],[],_,_,_) -> "o" - - (i,m,f,_,_,_) -> concatMap pronThaiChar (reverse $ f ++ m ++ i) ---- - - initCons = concatMap pronThaiChar $ case (reverse $ initc s) of - 0x0e2b:cs@(_:_) -> cs -- high h - 0x0e2d:cs@(_:_) -> cs -- O - cs -> cs - - finalCons = - let (c,cs) = splitAt 1 $ finalc s - in - case c of - [] -> [] - [0x0e22] -> [] --- y - [k] -> concatMap pronThaiChar (reverse cs) ++ finalThai k - - iclass = case take 1 (reverse $ initc s) of - [c] -> classThai c - [] -> CMid -- O - - isLong = not (shorten s) && case vowel of - _:_:_ -> True ---- - _ -> False - - isLive = case finalCons of - c | elem c ["n","m","g"] -> True - "" -> isLong - _ -> False - - tonem = case (iclass,isLive,isLong,tone s) of - (_,_,_, [0x0e4a]) -> tHigh - (_,_,_, [0x0e4b]) -> tRise - (CLow,_,_,[0x0e49]) -> tRise - (_,_,_, [0x0e49]) -> tFall - (CLow,_,_,[0x0e48]) -> tFall - (_, _,_,[0x0e48]) -> tLow - (CHigh,True,_,_) -> tRise - (_, True,_,_) -> tMid - (CLow,False,False,_) -> tHigh - (CLow,False,_,_) -> tFall - _ -> tLow - -(tMid,tHigh,tLow,tRise,tFall) = ("-","'","`","~","^") - -isVowel c = 0x0e30 <= c && c <= 0x0e44 ---- -isCons c = 0x0e01 <= c && c <= 0x0e2f ---- -isTone c = 0x0e48 <= c && c <= 0x0e4b - -getSyllable :: [Int] -> Syllable -getSyllable = foldl get (Syll [] [] [] [] [] [] False False) where - get syll c = case c of - 0x0e47 -> syll {shorten = True} - 0x0e4c -> syll {kill = True, finalc = tail (finalc syll)} --- always last - 0x0e2d - | null (initc syll) -> syll {initc = [c]} -- "O" - | otherwise -> syll {midv = c : midv syll} - _ - | isVowel c -> if null (initc syll) - then syll {initv = c : initv syll} - else syll {midv = c : midv syll} - | isCons c -> if null (initc syll) || - (null (midv syll) && isCluster (initc syll) c) - then syll {initc = c : initc syll} - else syll {finalc = c : finalc syll} - | isTone c -> syll {tone = [c]} - _ -> syll ---- check this - - isCluster s c = length s == 1 && (c == 0x0e23 || s == [0x0e2b]) - --- to test - -test1 = testThai "k2wa:mrak" -test2 = putStrLn $ thaiTable -test3 = do - writeFile "thai.txt" "Thai Character Coding in GF\nAR 2007\n" - appendFile "thai.txt" thaiTable -test4 = do - writeFile "alphthai.txt" "Thai Characters by Pronunciation\nAR 2007\n" - appendFile "alphthai.txt" thaiTableAlph - - -testThai :: String -> IO () -testThai s = do - putStrLn $ encodeUTF8 $ mkThai s - putStrLn $ unwords $ map mkPronSyllable $ words s - -testSyllable s = - let y = getSyllable $ map mkThaiChar $ unchar s - in - putStrLn $ pronSyllable $ trace (show y) y - -thaiFile :: FilePath -> Maybe FilePath -> IO () -thaiFile f mo = do - s <- readFile f - let put = maybe putStr writeFile mo - put $ encodeUTF8 $ thaiStrings s - -thaiPronFile :: FilePath -> Maybe FilePath -> IO () -thaiPronFile f mo = do - s <- readFile f - let put = maybe putStr writeFile mo - put $ encodeUTF8 $ thaiPronStrings s - -thaiFakeFile :: FilePath -> Maybe FilePath -> IO () -thaiFakeFile f mo = do - s <- readFile f - let put = maybe putStr writeFile mo - put $ encodeUTF8 $ (convStrings mkThaiFake) s - -finalThai c = maybe "" return (Map.lookup c thaiFinalMap) -thaiFinalMap = Map.fromList $ zip allThaiCodes finals - -classThai c = maybe CLow readClass (Map.lookup c thaiClassMap) -thaiClassMap = Map.fromList $ zip allThaiCodes heights - -readClass s = case s of - 'L' -> CLow - 'M' -> CMid - 'H' -> CHigh - - -thaiTable :: String -thaiTable = unlines $ ("\n|| hex | thai | trans | pron | fin | class |" ) : [ - "| " ++ - hex c ++ " | " ++ - encodeUTF8 (showThai s) ++ " | " ++ - s ++ " | " ++ - pronThai s ++ " | " ++ - [f] ++ " | " ++ - [q] ++ " | " - | - (c,q,f,s) <- zip4 allThaiCodes heights finals allThaiTrans - ] - -thaiTableAlph :: String -thaiTableAlph = unlines $ ("\n|| pron | thai | trans |" ) : [ - "| " ++ a ++ - " | " ++ unwords (map (encodeUTF8 . showThai) ss) ++ - " | " ++ unwords ss ++ - " |" - | - (a,ss) <- allProns - ] - where - prons = sort $ nub - [p | s <- allThaiTrans, let p = pronThai s, not (null p),isAlpha (head p)] - allProns = - [(a,[s | s <- allThaiTrans, pronThai s == a]) | a <- prons] - -showThai s = case s of - "-" -> "-" ---- v:_ | elem v "ivu" -> map (toEnum . mkThaiChar) ["O",s] - _ -> [toEnum $ mkThaiChar s] - - -pronThaiChar = pronThai . recodeThai - -recodeThai c = allThaiTrans !! (c - 0x0e00) - -pronThai s = case s of - [c,p] - | c == 'N' && isDigit p -> [p] - | c == 'T' && isDigit p -> ['\'',p] - | isDigit p -> c:"h" - | p==':' -> c:[c] - | elem p "%&" -> c:"y" - | p=='+' -> c:"m" - | s == "e'" -> "\228\228" - | otherwise -> [c] - "O" -> "O" - "e" -> "ee" - [c] | isUpper c -> "" - _ -> s - -hex = map hx . reverse . digs where - digs 0 = [0] - digs n = n `mod` 16 : digs (n `div` 16) - hx d = "0123456789ABCDEF" !! d - -heights :: String -finals :: String -heights = - " MHHLLLLMHLLLLMMHLLLMMHLLLMMHHLLLLLL-L-LHHHHLML" ++ replicate 99 ' ' -finals = - " kkkkkkgt-tt-ntttttntttttnpp--pppmyn-n-wttt-n--" ++ replicate 99 ' ' diff --git a/src-3.0/GF/Text/Unicode.hs b/src-3.0/GF/Text/Unicode.hs deleted file mode 100644 index 9d0b9d1a8..000000000 --- a/src-3.0/GF/Text/Unicode.hs +++ /dev/null @@ -1,69 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Unicode --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:42 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.12 $ --- --- ad hoc Unicode conversions from different alphabets. --- AR 12\/4\/2000, 18\/9\/2001, 30\/5\/2002, 26\/1\/2004 ------------------------------------------------------------------------------ - -module GF.Text.Unicode (mkUnicode, treat) where - -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) - -import Data.Char - -mkUnicode :: String -> String -mkUnicode s = case s of - '/':'/':cs -> treat [] mkGreek unic ++ mkUnicode rest - '/':'+':cs -> mkHebrew unic ++ mkUnicode rest - '/':'-':cs -> mkArabic unic ++ mkUnicode rest - '/':'_':cs -> treat [] mkRussian unic ++ mkUnicode rest - '/':'*':cs -> mkRusKOI8 unic ++ mkUnicode rest - '/':'E':cs -> mkEthiopic unic ++ mkUnicode rest - '/':'T':cs -> mkTamil unic ++ mkUnicode rest - '/':'C':cs -> mkOCSCyrillic unic ++ mkUnicode rest - '/':'&':cs -> mkDevanagari unic ++ mkUnicode rest - '/':'L':cs -> mkLatinASupplement unic ++ mkUnicode rest - '/':'J':cs -> mkJapanese unic ++ mkUnicode rest - '/':'6':cs -> mkArabic0600 unic ++ mkUnicode rest - '/':'A':cs -> mkExtendedArabic unic ++ mkUnicode rest - '/':'X':cs -> mkExtraDiacritics unic ++ mkUnicode rest - c:cs -> c:mkUnicode cs - _ -> s - where - (unic,rest) = remClosing [] $ dropWhile isSpace $ drop 2 s - remClosing u s = case s of - c:'/':s | elem c "/+-_*ETC&LJ6AX" -> (reverse u, s) --- end need not match - c:cs -> remClosing (c:u) cs - _ -> (reverse u,[]) -- forgiving missing end - --- | don't convert XML tags --- assumes \<\> always means XML tags -treat :: String -> (String -> String) -> String -> String -treat old mk s = case s of - '<':cs -> mk (reverse old) ++ '<':noTreat cs - c:cs -> treat (c:old) mk cs - _ -> mk (reverse old) - where - noTreat s = case s of - '>':cs -> '>' : treat [] mk cs - c:cs -> c : noTreat cs - _ -> s diff --git a/src-3.0/GF/Translate/GFT.hs b/src-3.0/GF/Translate/GFT.hs deleted file mode 100644 index e4a9d8193..000000000 --- a/src-3.0/GF/Translate/GFT.hs +++ /dev/null @@ -1,56 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:43 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Translate.GFT (main) where - -import GF.Compile.ShellState -import GF.Canon.GetGFC -import GF.API - -import GF.Text.Unicode -import GF.Text.UTF8 -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Infra.Modules (emptyMGrammar) ---- -import GF.Data.Operations - -import System -import Data.List - - -main :: IO () -main = do - file:_ <- getArgs - let opts = noOptions - can <- useIOE (error "no grammar file") $ getCanonGrammar file - st <- err error return $ - grammar2shellState opts (can, emptyMGrammar) - let grs = allStateGrammars st - let cat = firstCatOpts opts (firstStateGrammar st) - ----- interact (doTranslate grs cat) - s <- getLine - putStrLnFlush $ doTranslate grs cat $ drop 2 s -- to remove "n=" - -doTranslate grs cat s = - let ss = [l +++ ":" +++ s | (l,s) <- zip (map (prIdent . cncId) grs) - (translateBetweenAll grs cat s)] - in mkHTML ss - -mkHTML = unlines . htmlDoc . intersperse "

" . map (encodeUTF8 . mkUnicode) . sort - -htmlDoc ss = "":metaHead:"": ss ++ ["",""] - -metaHead = - "" - 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, ["+" ++ 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= 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 == "" - -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 ((/=" 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 diff --git a/src-3.0/GF/Visualization/Graphviz.hs b/src-3.0/GF/Visualization/Graphviz.hs deleted file mode 100644 index b59e3ecd2..000000000 --- a/src-3.0/GF/Visualization/Graphviz.hs +++ /dev/null @@ -1,116 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Graphviz --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/15 18:10:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Graphviz DOT format representation and printing. ------------------------------------------------------------------------------ - -module GF.Visualization.Graphviz ( - Graph(..), GraphType(..), - Node(..), Edge(..), - Attr, - addSubGraphs, - setName, - setAttr, - prGraphviz - ) where - -import Data.Char - -import GF.Data.Utilities - --- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs -data Graph = Graph { - gType :: GraphType, - gId :: Maybe String, - gAttrs :: [Attr], - gNodes :: [Node], - gEdges :: [Edge], - gSubgraphs :: [Graph] - } - deriving (Show) - -data GraphType = Directed | Undirected - deriving (Show) - -data Node = Node String [Attr] - deriving Show - -data Edge = Edge String String [Attr] - deriving Show - -type Attr = (String,String) - --- --- * Graph construction --- - -addSubGraphs :: [Graph] -> Graph -> Graph -addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g } - -setName :: String -> Graph -> Graph -setName n g = g { gId = Just n } - -setAttr :: String -> String -> Graph -> Graph -setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) } - --- --- * Pretty-printing --- - -prGraphviz :: Graph -> String -prGraphviz g@(Graph t i _ _ _ _) = - graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n" - -prSubGraph :: Graph -> String -prSubGraph g@(Graph _ i _ _ _ _) = - "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}" - -prGraph :: Graph -> String -prGraph (Graph t id at ns es ss) = - unlines $ map (++";") (map prAttr at - ++ map prNode ns - ++ map (prEdge t) es - ++ map prSubGraph ss) - -graphtype :: GraphType -> String -graphtype Directed = "digraph" -graphtype Undirected = "graph" - -prNode :: Node -> String -prNode (Node n at) = esc n ++ " " ++ prAttrList at - -prEdge :: GraphType -> Edge -> String -prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ esc y ++ " " ++ prAttrList at - -edgeop :: GraphType -> String -edgeop Directed = "->" -edgeop Undirected = "--" - -prAttrList :: [Attr] -> String -prAttrList [] = "" -prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" - -prAttr :: Attr -> String -prAttr (n,v) = esc n ++ " = " ++ esc v - -esc :: String -> String -esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\"" - | otherwise = s - where shouldEsc = (`elem` ['"', '\\']) - -needEsc :: String -> Bool -needEsc [] = True -needEsc xs | all isDigit xs = False -needEsc (x:xs) = not (isIDFirst x && all isIDChar xs) - -isIDFirst, isIDChar :: Char -> Bool -isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z']) -isIDChar c = isIDFirst c || isDigit c diff --git a/src-3.0/GF/Visualization/VisualizeGrammar.hs b/src-3.0/GF/Visualization/VisualizeGrammar.hs deleted file mode 100644 index b5446aec8..000000000 --- a/src-3.0/GF/Visualization/VisualizeGrammar.hs +++ /dev/null @@ -1,125 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : VisualizeGrammar --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/14 15:17:30 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.10 $ --- --- Print a graph of module dependencies in Graphviz DOT format --- FIXME: change this to use GF.Visualization.Graphviz, --- instead of rolling its own. ------------------------------------------------------------------------------ - -module GF.Visualization.VisualizeGrammar ( visualizeCanonGrammar, - visualizeSourceGrammar - ) where - -import qualified GF.Infra.Modules as M -import GF.Canon.GFC -import GF.Infra.Ident -import GF.Infra.Option -import GF.Grammar.Grammar (SourceGrammar) - -import Data.List (intersperse, nub) -import Data.Maybe (maybeToList) - -data GrType = GrAbstract - | GrConcrete - | GrResource - | GrInterface - | GrInstance - deriving Show - -data Node = Node { - label :: String, - url :: String, - grtype :: GrType, - extends :: [String], - opens :: [String], - implements :: Maybe String - } - deriving Show - - -visualizeCanonGrammar :: Options -> CanonGrammar -> String -visualizeCanonGrammar opts = prGraph . canon2graph - -visualizeSourceGrammar :: SourceGrammar -> String -visualizeSourceGrammar = prGraph . source2graph - -canon2graph :: CanonGrammar -> [Node] -canon2graph gr = [ toNode i m | (i,M.ModMod m) <- M.modules gr ] - -source2graph :: SourceGrammar -> [Node] -source2graph gr = [ toNode i m | (i,M.ModMod m) <- M.modules gr ] -- FIXME: handle ModWith? - -toNode :: Ident -> M.Module Ident f i -> Node -toNode i m = Node { - label = l, - url = l ++ ".gf", -- FIXME: might be in a different directory - grtype = t, - extends = map prIdent (M.extends m), - opens = nub $ map openName (M.opens m), -- FIXME: nub is needed because of triple open with - -- instance modules - implements = is - } - where - l = prIdent i - (t,is) = fromModType (M.mtype m) - -fromModType :: M.ModuleType Ident -> (GrType, Maybe String) -fromModType t = case t of - M.MTAbstract -> (GrAbstract, Nothing) - M.MTTransfer _ _ -> error "Can't visualize transfer modules yet" -- FIXME - M.MTConcrete i -> (GrConcrete, Just (prIdent i)) - M.MTResource -> (GrResource, Nothing) - M.MTInterface -> (GrInterface, Nothing) - M.MTInstance i -> (GrInstance, Just (prIdent i)) - M.MTReuse rt -> error "Can't visualize reuse modules yet" -- FIXME - M.MTUnion _ _ -> error "Can't visualize union modules yet" -- FIXME - --- | FIXME: there is something odd about OQualif with 'with' modules, --- both names seem to be the same. -openName :: M.OpenSpec Ident -> String -openName (M.OSimple q i) = prIdent i -openName (M.OQualif q i _) = prIdent i - -prGraph :: [Node] -> String -prGraph ns = concat $ map (++"\n") $ ["digraph {\n"] ++ map prNode ns ++ ["}"] - -prNode :: Node -> String -prNode n = concat (map (++";\n") stmts) - where - l = label n - t = grtype n - stmts = [l ++ " [" ++ prAttributes attrs ++ "]"] - ++ map (prExtend t l) (extends n) - ++ map (prOpen l) (opens n) - ++ map (prImplement t l) (maybeToList (implements n)) - (shape,style) = case t of - GrAbstract -> ("ellipse","solid") - GrConcrete -> ("box","dashed") - GrResource -> ("ellipse","dashed") - GrInterface -> ("ellipse","dotted") - GrInstance -> ("diamond","dotted") - attrs = [("style", style),("shape", shape),("URL", url n)] - - -prExtend :: GrType -> String -> String -> String -prExtend g f t = prEdge f t [("style","solid")] - -prOpen :: String -> String -> String -prOpen f t = prEdge f t [("style","dotted")] - -prImplement :: GrType -> String -> String -> String -prImplement g f t = prEdge f t [("arrowhead","empty"),("style","dashed")] - -prEdge :: String -> String -> [(String,String)] -> String -prEdge f t as = f ++ " -> " ++ t ++ " [" ++ prAttributes as ++ "]" - -prAttributes :: [(String,String)] -> String -prAttributes = concat . intersperse ", " . map (\ (n,v) -> n ++ " = " ++ show v) diff --git a/src-3.0/GF/Visualization/VisualizeTree.hs b/src-3.0/GF/Visualization/VisualizeTree.hs deleted file mode 100644 index 5fe740c12..000000000 --- a/src-3.0/GF/Visualization/VisualizeTree.hs +++ /dev/null @@ -1,58 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : VisualizeTree --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Print a graph of an abstract syntax tree in Graphviz DOT format --- Based on BB's VisualizeGrammar --- FIXME: change this to use GF.Visualization.Graphviz, --- instead of rolling its own. ------------------------------------------------------------------------------ - -module GF.Visualization.VisualizeTree ( visualizeTrees - ) where - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Grammar.Abstract -import GF.Data.Zipper -import GF.Grammar.PrGrammar - -import Data.List (intersperse, nub) -import Data.Maybe (maybeToList) - -visualizeTrees :: Options -> [Tree] -> String -visualizeTrees opts = unlines . map (prGraph opts . tree2graph opts) - -tree2graph :: Options -> Tree -> [String] -tree2graph opts = prf [] where - prf ps t@(Tr (node, trees)) = - let (nod,lab) = prn ps node in - (nod ++ " [label = " ++ lab ++ ", style = \"solid\", shape = \"plaintext\"] ;") : - [ pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++ - concat [prf (j:ps) t | (j,t) <- zip [0..] trees] - prn ps (N (bi,at,val,_,_)) = - let - lab = - "\"" ++ - prb bi ++ - prc at val ++ - "\"" - in if oElem (iOpt "g") opts then (lab,lab) else (show(show (ps :: [Int])),lab) - prb [] = "" - prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> " - pra i nod t@(Tr (node,_)) = nod ++ arr ++ fst (prn i node) ++ " [style = \"solid\"];" - prc a v - | oElem (iOpt "c") opts = prt_ v - | oElem (iOpt "f") opts = prt_ a - | otherwise = prt_ a ++ " : " ++ prt_ v - arr = if oElem (iOpt "g") opts then " -> " else " -- " - -prGraph opts ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where - graph = if oElem (iOpt "g") opts then "digraph" else "graph"