From b96b36f43de3e2f8b58d5f539daa6f6d47f25870 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 25 Jun 2008 16:43:48 +0000 Subject: removed src for 2.9 --- src/GF/API.hs | 472 -- src/GF/API/BatchTranslate.hs | 43 - src/GF/API/GrammarToHaskell.hs | 271 - src/GF/API/GrammarToTransfer.hs | 94 - src/GF/API/IOGrammar.hs | 96 - src/GF/API/MyParser.hs | 25 - src/GF/CF/CF.hs | 213 - src/GF/CF/CFIdent.hs | 253 - src/GF/CF/CFtoGrammar.hs | 62 - src/GF/CF/CanonToCF.hs | 214 - src/GF/CF/ChartParser.hs | 206 - src/GF/CF/EBNF.hs | 191 - src/GF/CF/PPrCF.hs | 102 - src/GF/CF/PrLBNF.hs | 150 - src/GF/CF/Profile.hs | 106 - src/GF/CFGM/AbsCFG.hs | 45 - src/GF/CFGM/CFG.cf | 36 - src/GF/CFGM/LexCFG.hs | 312 - src/GF/CFGM/LexCFG.x | 135 - src/GF/CFGM/ParCFG.hs | 779 -- src/GF/CFGM/ParCFG.y | 129 - src/GF/CFGM/PrintCFG.hs | 157 - src/GF/CFGM/PrintCFGrammar.hs | 113 - src/GF/Canon/AbsGFC.hs | 182 - src/GF/Canon/AbsToBNF.hs | 38 - src/GF/Canon/CMacros.hs | 334 - src/GF/Canon/CanonToGFCC.hs | 45 - src/GF/Canon/CanonToGrammar.hs | 203 - src/GF/Canon/GFC.cf | 170 - src/GF/Canon/GFC.hs | 103 - src/GF/Canon/GetGFC.hs | 78 - src/GF/Canon/LexGFC.hs | 346 - src/GF/Canon/LexGFC.x | 132 - src/GF/Canon/Look.hs | 225 - src/GF/Canon/MkGFC.hs | 237 - src/GF/Canon/ParGFC.hs | 2142 ------ src/GF/Canon/ParGFC.y | 385 - src/GF/Canon/PrExp.hs | 46 - src/GF/Canon/PrintGFC.hs | 376 - src/GF/Canon/Share.hs | 147 - src/GF/Canon/SkelGFC.hs | 217 - src/GF/Canon/Subexpressions.hs | 170 - src/GF/Canon/TestGFC.hs | 58 - src/GF/Canon/Unlex.hs | 49 - src/GF/Canon/Unparametrize.hs | 63 - src/GF/Canon/log.txt | 20 - src/GF/Command/AbsGFShell.hs | 42 - src/GF/Command/Commands.hs | 159 - src/GF/Command/GFShell.cf | 27 - src/GF/Command/Importing.hs | 28 - src/GF/Command/Interpreter.hs | 74 - src/GF/Command/LexGFShell.hs | 337 - src/GF/Command/PPrTree.hs | 39 - src/GF/Command/ParGFShell.hs | 809 -- src/GF/Command/PrintGFShell.hs | 144 - src/GF/Compile/API.hs | 21 - src/GF/Compile/BackOpt.hs | 141 - src/GF/Compile/CheckGrammar.hs | 1078 --- src/GF/Compile/Compile.hs | 401 - src/GF/Compile/Evaluate.hs | 477 -- src/GF/Compile/Extend.hs | 136 - src/GF/Compile/Flatten.hs | 92 - src/GF/Compile/GetGrammar.hs | 146 - src/GF/Compile/GrammarToCanon.hs | 293 - src/GF/Compile/MkConcrete.hs | 154 - src/GF/Compile/MkResource.hs | 128 - src/GF/Compile/MkUnion.hs | 83 - src/GF/Compile/ModDeps.hs | 153 - src/GF/Compile/NewRename.hs | 294 - src/GF/Compile/NoParse.hs | 49 - src/GF/Compile/Optimize.hs | 300 - src/GF/Compile/PGrammar.hs | 77 - src/GF/Compile/PrOld.hs | 84 - src/GF/Compile/Rebuild.hs | 99 - src/GF/Compile/RemoveLiT.hs | 63 - src/GF/Compile/Rename.hs | 338 - src/GF/Compile/ShellState.hs | 568 -- src/GF/Compile/Update.hs | 135 - src/GF/Compile/Wordlist.hs | 108 - src/GF/Conversion/GFC.hs | 157 - src/GF/Conversion/GFCtoSimple.hs | 175 - src/GF/Conversion/Haskell.hs | 71 - src/GF/Conversion/MCFGtoCFG.hs | 53 - src/GF/Conversion/MCFGtoFCFG.hs | 51 - src/GF/Conversion/Prolog.hs | 205 - src/GF/Conversion/RemoveEpsilon.hs | 46 - src/GF/Conversion/RemoveErasing.hs | 113 - src/GF/Conversion/RemoveSingletons.hs | 82 - src/GF/Conversion/SimpleToFCFG.hs | 536 -- src/GF/Conversion/SimpleToFinite.hs | 178 - src/GF/Conversion/SimpleToMCFG.hs | 26 - src/GF/Conversion/SimpleToMCFG/Coercions.hs | 63 - src/GF/Conversion/SimpleToMCFG/Nondet.hs | 256 - src/GF/Conversion/SimpleToMCFG/Strict.hs | 129 - src/GF/Conversion/TypeGraph.hs | 58 - src/GF/Conversion/Types.hs | 146 - src/GF/Data/Assoc.hs | 143 - src/GF/Data/BacktrackM.hs | 93 - src/GF/Data/Compos.hs | 37 - src/GF/Data/ErrM.hs | 38 - src/GF/Data/GeneralDeduction.hs | 121 - src/GF/Data/Glue.hs | 30 - src/GF/Data/IncrementalDeduction.hs | 67 - src/GF/Data/Map.hs | 61 - src/GF/Data/Operations.hs | 658 -- src/GF/Data/OrdMap2.hs | 127 - src/GF/Data/OrdSet.hs | 120 - src/GF/Data/Parsers.hs | 196 - src/GF/Data/RedBlack.hs | 64 - src/GF/Data/RedBlackSet.hs | 150 - src/GF/Data/SharedString.hs | 19 - src/GF/Data/SortedList.hs | 127 - src/GF/Data/Str.hs | 134 - src/GF/Data/Trie.hs | 129 - src/GF/Data/Trie2.hs | 120 - src/GF/Data/Utilities.hs | 190 - src/GF/Data/XML.hs | 57 - src/GF/Data/Zipper.hs | 257 - src/GF/Devel/AbsCompute.hs | 145 - src/GF/Devel/Arch.hs | 89 - src/GF/Devel/CheckGrammar.hs | 1090 --- src/GF/Devel/CheckM.hs | 89 - src/GF/Devel/Compile.hs | 203 - src/GF/Devel/Compile/AbsGF.hs | 274 - src/GF/Devel/Compile/CheckGrammar.hs | 1089 --- src/GF/Devel/Compile/Compile.hs | 205 - src/GF/Devel/Compile/ErrM.hs | 26 - src/GF/Devel/Compile/Extend.hs | 154 - src/GF/Devel/Compile/Factorize.hs | 251 - src/GF/Devel/Compile/GF.cf | 326 - src/GF/Devel/Compile/GFC.hs | 72 - src/GF/Devel/Compile/GFtoGFCC.hs | 542 -- src/GF/Devel/Compile/GetGrammar.hs | 56 - src/GF/Devel/Compile/LexGF.hs | 343 - src/GF/Devel/Compile/Optimize.hs | 333 - src/GF/Devel/Compile/ParGF.hs | 3210 -------- src/GF/Devel/Compile/PrintGF.hs | 481 -- src/GF/Devel/Compile/Refresh.hs | 118 - src/GF/Devel/Compile/Rename.hs | 239 - src/GF/Devel/Compile/SourceToGF.hs | 679 -- src/GF/Devel/Compute.hs | 455 -- src/GF/Devel/GF.hs | 14 - src/GF/Devel/GFC.hs | 67 - src/GF/Devel/GFC/Main.hs | 28 - src/GF/Devel/GFCCInterpreter.hs | 28 - src/GF/Devel/GFCCtoHaskell.hs | 213 - src/GF/Devel/GFCCtoJS.hs | 132 - src/GF/Devel/GFI.hs | 77 - src/GF/Devel/GetGrammar.hs | 54 - src/GF/Devel/Grammar/AppPredefined.hs | 166 - src/GF/Devel/Grammar/Compute.hs | 380 - src/GF/Devel/Grammar/Construct.hs | 221 - src/GF/Devel/Grammar/GFtoSource.hs | 223 - src/GF/Devel/Grammar/Grammar.hs | 172 - src/GF/Devel/Grammar/Lookup.hs | 168 - src/GF/Devel/Grammar/Macros.hs | 434 -- src/GF/Devel/Grammar/PatternMatch.hs | 146 - src/GF/Devel/Grammar/PrGF.hs | 246 - src/GF/Devel/GrammarToGFCC.hs | 545 -- src/GF/Devel/Infra/ReadFiles.hs | 348 - src/GF/Devel/ModDeps.hs | 153 - src/GF/Devel/Optimize.hs | 299 - src/GF/Devel/OptimizeGF.hs | 271 - src/GF/Devel/Options.hs | 269 - src/GF/Devel/PrGrammar.hs | 233 - src/GF/Devel/PrintGFCC.hs | 21 - src/GF/Devel/README-testgf3 | 49 - src/GF/Devel/ReadFiles.hs | 196 - src/GF/Devel/TC.hs | 299 - src/GF/Devel/TestGF3.hs | 9 - src/GF/Devel/TypeCheck.hs | 311 - src/GF/Devel/UseIO.hs | 298 - src/GF/Devel/gf-code.txt | 66 - src/GF/Devel/gf3.txt | 84 - src/GF/Embed/EmbedAPI.hs | 114 - src/GF/Embed/EmbedCustom.hs | 113 - src/GF/Embed/EmbedParsing.hs | 65 - src/GF/Embed/TemplateApp.hs | 44 - src/GF/Formalism/CFG.hs | 50 - src/GF/Formalism/FCFG.hs | 106 - src/GF/Formalism/GCFG.hs | 47 - src/GF/Formalism/MCFG.hs | 58 - src/GF/Formalism/SimpleGFC.hs | 268 - src/GF/Formalism/Utilities.hs | 423 -- src/GF/Fudgets/ArchEdit.hs | 30 - src/GF/Fudgets/CommandF.hs | 134 - src/GF/Fudgets/EventF.hs | 51 - src/GF/Fudgets/FudgetOps.hs | 59 - src/GF/Fudgets/UnicodeF.hs | 37 - src/GF/GFCC/API.hs | 140 - src/GF/GFCC/CId.hs | 14 - src/GF/GFCC/CheckGFCC.hs | 186 - src/GF/GFCC/ComposOp.hs | 30 - src/GF/GFCC/DataGFCC.hs | 152 - src/GF/GFCC/GFCC.cf | 81 - src/GF/GFCC/Generate.hs | 70 - src/GF/GFCC/LexGFCC.hs | 349 - src/GF/GFCC/Linearize.hs | 91 - src/GF/GFCC/Macros.hs | 121 - src/GF/GFCC/OptimizeGFCC.hs | 116 - src/GF/GFCC/Raw/AbsGFCCRaw.hs | 17 - src/GF/GFCC/Raw/ConvertGFCC.hs | 277 - src/GF/GFCC/Raw/GFCCRaw.cf | 12 - src/GF/GFCC/Raw/ParGFCCRaw.hs | 99 - src/GF/GFCC/Raw/PrintGFCCRaw.hs | 36 - src/GF/GFCC/ShowLinearize.hs | 87 - src/GF/GFCC/SkelGFCC.hs | 109 - src/GF/GFCC/TestGFCC.hs | 58 - src/GF/GFCC/doc/Eng.gf | 13 - src/GF/GFCC/doc/Ex.gf | 8 - src/GF/GFCC/doc/Swe.gf | 13 - src/GF/GFCC/doc/Test.gf | 64 - src/GF/GFCC/doc/gfcc.html | 809 -- src/GF/GFCC/doc/gfcc.txt | 712 -- src/GF/GFCC/doc/old-GFCC.cf | 50 - src/GF/GFCC/doc/old-gfcc.txt | 656 -- src/GF/GFCC/doc/syntax.txt | 180 - src/GF/GFModes.hs | 112 - src/GF/Grammar/AbsCompute.hs | 145 - src/GF/Grammar/Abstract.hs | 38 - src/GF/Grammar/AppPredefined.hs | 159 - src/GF/Grammar/Compute.hs | 426 -- src/GF/Grammar/Grammar.hs | 244 - src/GF/Grammar/Lockfield.hs | 46 - src/GF/Grammar/LookAbs.hs | 196 - src/GF/Grammar/Lookup.hs | 275 - src/GF/Grammar/MMacros.hs | 341 - src/GF/Grammar/Macros.hs | 817 -- src/GF/Grammar/PatternMatch.hs | 155 - src/GF/Grammar/PrGrammar.hs | 286 - src/GF/Grammar/Refresh.hs | 133 - src/GF/Grammar/ReservedWords.hs | 44 - src/GF/Grammar/SGrammar.hs | 169 - src/GF/Grammar/TC.hs | 299 - src/GF/Grammar/TypeCheck.hs | 311 - src/GF/Grammar/Unify.hs | 96 - src/GF/Grammar/Values.hs | 109 - src/GF/IDE/IDECommands.hs | 95 - src/GF/Infra/CheckM.hs | 89 - src/GF/Infra/Comments.hs | 43 - src/GF/Infra/CompactPrint.hs | 22 - src/GF/Infra/Ident.hs | 155 - src/GF/Infra/Modules.hs | 416 -- src/GF/Infra/Option.hs | 375 - src/GF/Infra/Print.hs | 127 - src/GF/Infra/PrintClass.hs | 51 - src/GF/Infra/ReadFiles.hs | 362 - src/GF/Infra/UseIO.hs | 330 - src/GF/JavaScript/AbsJS.hs | 60 - src/GF/JavaScript/JS.cf | 55 - src/GF/JavaScript/LexJS.hs | 337 - src/GF/JavaScript/LexJS.x | 132 - src/GF/JavaScript/Makefile | 14 - src/GF/JavaScript/ParJS.hs | 1175 --- src/GF/JavaScript/ParJS.y | 225 - src/GF/JavaScript/PrintJS.hs | 169 - src/GF/JavaScript/SkelJS.hs | 80 - src/GF/JavaScript/TestJS.hs | 58 - src/GF/OldParsing/CFGrammar.hs | 153 - src/GF/OldParsing/ConvertFiniteGFC.hs | 283 - src/GF/OldParsing/ConvertFiniteSimple.hs | 121 - src/GF/OldParsing/ConvertGFCtoMCFG.hs | 34 - src/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs | 71 - src/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs | 281 - src/GF/OldParsing/ConvertGFCtoMCFG/Old.hs | 277 - src/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs | 189 - src/GF/OldParsing/ConvertGFCtoSimple.hs | 122 - src/GF/OldParsing/ConvertGrammar.hs | 44 - src/GF/OldParsing/ConvertMCFGtoCFG.hs | 52 - src/GF/OldParsing/ConvertSimpleToMCFG.hs | 30 - src/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs | 70 - src/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs | 245 - src/GF/OldParsing/ConvertSimpleToMCFG/Old.hs | 277 - src/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs | 139 - src/GF/OldParsing/GCFG.hs | 43 - src/GF/OldParsing/GeneralChart.hs | 86 - src/GF/OldParsing/GrammarTypes.hs | 148 - src/GF/OldParsing/IncrementalChart.hs | 50 - src/GF/OldParsing/MCFGrammar.hs | 206 - src/GF/OldParsing/ParseCF.hs | 82 - src/GF/OldParsing/ParseCFG.hs | 43 - src/GF/OldParsing/ParseCFG/General.hs | 83 - src/GF/OldParsing/ParseCFG/Incremental.hs | 142 - src/GF/OldParsing/ParseGFC.hs | 177 - src/GF/OldParsing/ParseMCFG.hs | 37 - src/GF/OldParsing/ParseMCFG/Basic.hs | 156 - src/GF/OldParsing/SimpleGFC.hs | 161 - src/GF/OldParsing/Utilities.hs | 188 - src/GF/Parsing/CF.hs | 66 - src/GF/Parsing/CFG.hs | 51 - src/GF/Parsing/CFG/General.hs | 103 - src/GF/Parsing/CFG/Incremental.hs | 150 - src/GF/Parsing/CFG/PInfo.hs | 98 - src/GF/Parsing/FCFG.hs | 100 - src/GF/Parsing/FCFG/Active.hs | 179 - src/GF/Parsing/FCFG/Incremental.hs | 107 - src/GF/Parsing/FCFG/PInfo.hs | 121 - src/GF/Parsing/FCFG/Range.hs | 50 - src/GF/Parsing/GFC.hs | 208 - src/GF/Parsing/MCFG.hs | 68 - src/GF/Parsing/MCFG/Active.hs | 318 - src/GF/Parsing/MCFG/Active2.hs | 237 - src/GF/Parsing/MCFG/FastActive.hs | 176 - src/GF/Parsing/MCFG/Incremental.hs | 178 - src/GF/Parsing/MCFG/Incremental2.hs | 157 - src/GF/Parsing/MCFG/Naive.hs | 142 - src/GF/Parsing/MCFG/PInfo.hs | 162 - src/GF/Parsing/MCFG/Range.hs | 206 - src/GF/Parsing/MCFG/ViaCFG.hs | 186 - src/GF/Printing/PrintParser.hs | 83 - src/GF/Printing/PrintSimplifiedTerm.hs | 127 - src/GF/Probabilistic/Probabilistic.hs | 203 - src/GF/Shell.hs | 591 -- src/GF/Shell/CommandL.hs | 198 - src/GF/Shell/Commands.hs | 568 -- src/GF/Shell/HelpFile.hs | 723 -- src/GF/Shell/JGF.hs | 89 - src/GF/Shell/PShell.hs | 174 - src/GF/Shell/ShellCommands.hs | 246 - src/GF/Shell/SubShell.hs | 66 - src/GF/Shell/TeachYourself.hs | 87 - src/GF/Source/AbsGF.hs | 306 - src/GF/Source/ErrM.hs | 26 - src/GF/Source/GF.cf | 370 - src/GF/Source/GrammarToSource.hs | 259 - src/GF/Source/LexGF.hs | 345 - src/GF/Source/LexGF.x | 137 - src/GF/Source/ParGF.hs | 7845 -------------------- src/GF/Source/ParGF.y | 642 -- src/GF/Source/PrintGF.hs | 532 -- src/GF/Source/SkelGF.hs | 364 - src/GF/Source/SourceToGrammar.hs | 755 -- src/GF/Source/TestGF.hs | 58 - src/GF/Speech/CFGToFiniteState.hs | 265 - src/GF/Speech/FiniteState.hs | 329 - src/GF/Speech/GrammarToVoiceXML.hs | 285 - src/GF/Speech/Graph.hs | 178 - src/GF/Speech/PrFA.hs | 56 - src/GF/Speech/PrGSL.hs | 113 - src/GF/Speech/PrJSGF.hs | 145 - src/GF/Speech/PrRegExp.hs | 33 - src/GF/Speech/PrSLF.hs | 190 - src/GF/Speech/PrSRGS.hs | 153 - src/GF/Speech/PrSRGS_ABNF.hs | 147 - src/GF/Speech/RegExp.hs | 143 - src/GF/Speech/Relation.hs | 130 - src/GF/Speech/RelationQC.hs | 39 - src/GF/Speech/SISR.hs | 87 - src/GF/Speech/SRG.hs | 235 - src/GF/Speech/TransformCFG.hs | 378 - src/GF/System/ATKSpeechInput.hs | 137 - src/GF/System/Arch.hs | 90 - src/GF/System/ArchEdit.hs | 30 - src/GF/System/NoReadline.hs | 27 - src/GF/System/NoSignal.hs | 29 - src/GF/System/NoSpeechInput.hs | 28 - src/GF/System/Readline.hs | 27 - src/GF/System/Signal.hs | 27 - src/GF/System/SpeechInput.hs | 27 - src/GF/System/Tracing.hs | 73 - src/GF/System/UseReadline.hs | 25 - src/GF/System/UseSignal.hs | 58 - src/GF/Text/Arabic.hs | 63 - src/GF/Text/Devanagari.hs | 97 - src/GF/Text/Ethiopic.hs | 72 - src/GF/Text/ExtendedArabic.hs | 99 - src/GF/Text/ExtraDiacritics.hs | 37 - src/GF/Text/Greek.hs | 172 - src/GF/Text/Hebrew.hs | 53 - src/GF/Text/Hiragana.hs | 95 - src/GF/Text/LatinASupplement.hs | 69 - src/GF/Text/OCSCyrillic.hs | 47 - src/GF/Text/Russian.hs | 56 - src/GF/Text/Tamil.hs | 77 - src/GF/Text/Text.hs | 149 - src/GF/Text/Thai.hs | 368 - src/GF/Text/UTF8.hs | 48 - src/GF/Text/Unicode.hs | 69 - src/GF/Translate/GFT.hs | 56 - src/GF/UseGrammar/Custom.hs | 494 -- src/GF/UseGrammar/Editing.hs | 435 -- src/GF/UseGrammar/Generate.hs | 116 - src/GF/UseGrammar/GetTree.hs | 74 - src/GF/UseGrammar/Information.hs | 162 - src/GF/UseGrammar/Linear.hs | 292 - src/GF/UseGrammar/MatchTerm.hs | 50 - src/GF/UseGrammar/Morphology.hs | 140 - src/GF/UseGrammar/Paraphrases.hs | 70 - src/GF/UseGrammar/Parsing.hs | 177 - src/GF/UseGrammar/Randomized.hs | 66 - src/GF/UseGrammar/Session.hs | 181 - src/GF/UseGrammar/Statistics.hs | 44 - src/GF/UseGrammar/Tokenize.hs | 222 - src/GF/UseGrammar/Transfer.hs | 79 - src/GF/UseGrammar/TreeSelections.hs | 77 - src/GF/UseGrammar/Treebank.hs | 251 - src/GF/Visualization/Graphviz.hs | 116 - src/GF/Visualization/VisualizeGrammar.hs | 125 - src/GF/Visualization/VisualizeTree.hs | 58 - 399 files changed, 84126 deletions(-) delete mode 100644 src/GF/API.hs delete mode 100644 src/GF/API/BatchTranslate.hs delete mode 100644 src/GF/API/GrammarToHaskell.hs delete mode 100644 src/GF/API/GrammarToTransfer.hs delete mode 100644 src/GF/API/IOGrammar.hs delete mode 100644 src/GF/API/MyParser.hs delete mode 100644 src/GF/CF/CF.hs delete mode 100644 src/GF/CF/CFIdent.hs delete mode 100644 src/GF/CF/CFtoGrammar.hs delete mode 100644 src/GF/CF/CanonToCF.hs delete mode 100644 src/GF/CF/ChartParser.hs delete mode 100644 src/GF/CF/EBNF.hs delete mode 100644 src/GF/CF/PPrCF.hs delete mode 100644 src/GF/CF/PrLBNF.hs delete mode 100644 src/GF/CF/Profile.hs delete mode 100644 src/GF/CFGM/AbsCFG.hs delete mode 100644 src/GF/CFGM/CFG.cf delete mode 100644 src/GF/CFGM/LexCFG.hs delete mode 100644 src/GF/CFGM/LexCFG.x delete mode 100644 src/GF/CFGM/ParCFG.hs delete mode 100644 src/GF/CFGM/ParCFG.y delete mode 100644 src/GF/CFGM/PrintCFG.hs delete mode 100644 src/GF/CFGM/PrintCFGrammar.hs delete mode 100644 src/GF/Canon/AbsGFC.hs delete mode 100644 src/GF/Canon/AbsToBNF.hs delete mode 100644 src/GF/Canon/CMacros.hs delete mode 100644 src/GF/Canon/CanonToGFCC.hs delete mode 100644 src/GF/Canon/CanonToGrammar.hs delete mode 100644 src/GF/Canon/GFC.cf delete mode 100644 src/GF/Canon/GFC.hs delete mode 100644 src/GF/Canon/GetGFC.hs delete mode 100644 src/GF/Canon/LexGFC.hs delete mode 100644 src/GF/Canon/LexGFC.x delete mode 100644 src/GF/Canon/Look.hs delete mode 100644 src/GF/Canon/MkGFC.hs delete mode 100644 src/GF/Canon/ParGFC.hs delete mode 100644 src/GF/Canon/ParGFC.y delete mode 100644 src/GF/Canon/PrExp.hs delete mode 100644 src/GF/Canon/PrintGFC.hs delete mode 100644 src/GF/Canon/Share.hs delete mode 100644 src/GF/Canon/SkelGFC.hs delete mode 100644 src/GF/Canon/Subexpressions.hs delete mode 100644 src/GF/Canon/TestGFC.hs delete mode 100644 src/GF/Canon/Unlex.hs delete mode 100644 src/GF/Canon/Unparametrize.hs delete mode 100644 src/GF/Canon/log.txt delete mode 100644 src/GF/Command/AbsGFShell.hs delete mode 100644 src/GF/Command/Commands.hs delete mode 100644 src/GF/Command/GFShell.cf delete mode 100644 src/GF/Command/Importing.hs delete mode 100644 src/GF/Command/Interpreter.hs delete mode 100644 src/GF/Command/LexGFShell.hs delete mode 100644 src/GF/Command/PPrTree.hs delete mode 100644 src/GF/Command/ParGFShell.hs delete mode 100644 src/GF/Command/PrintGFShell.hs delete mode 100644 src/GF/Compile/API.hs delete mode 100644 src/GF/Compile/BackOpt.hs delete mode 100644 src/GF/Compile/CheckGrammar.hs delete mode 100644 src/GF/Compile/Compile.hs delete mode 100644 src/GF/Compile/Evaluate.hs delete mode 100644 src/GF/Compile/Extend.hs delete mode 100644 src/GF/Compile/Flatten.hs delete mode 100644 src/GF/Compile/GetGrammar.hs delete mode 100644 src/GF/Compile/GrammarToCanon.hs delete mode 100644 src/GF/Compile/MkConcrete.hs delete mode 100644 src/GF/Compile/MkResource.hs delete mode 100644 src/GF/Compile/MkUnion.hs delete mode 100644 src/GF/Compile/ModDeps.hs delete mode 100644 src/GF/Compile/NewRename.hs delete mode 100644 src/GF/Compile/NoParse.hs delete mode 100644 src/GF/Compile/Optimize.hs delete mode 100644 src/GF/Compile/PGrammar.hs delete mode 100644 src/GF/Compile/PrOld.hs delete mode 100644 src/GF/Compile/Rebuild.hs delete mode 100644 src/GF/Compile/RemoveLiT.hs delete mode 100644 src/GF/Compile/Rename.hs delete mode 100644 src/GF/Compile/ShellState.hs delete mode 100644 src/GF/Compile/Update.hs delete mode 100644 src/GF/Compile/Wordlist.hs delete mode 100644 src/GF/Conversion/GFC.hs delete mode 100644 src/GF/Conversion/GFCtoSimple.hs delete mode 100644 src/GF/Conversion/Haskell.hs delete mode 100644 src/GF/Conversion/MCFGtoCFG.hs delete mode 100644 src/GF/Conversion/MCFGtoFCFG.hs delete mode 100644 src/GF/Conversion/Prolog.hs delete mode 100644 src/GF/Conversion/RemoveEpsilon.hs delete mode 100644 src/GF/Conversion/RemoveErasing.hs delete mode 100644 src/GF/Conversion/RemoveSingletons.hs delete mode 100644 src/GF/Conversion/SimpleToFCFG.hs delete mode 100644 src/GF/Conversion/SimpleToFinite.hs delete mode 100644 src/GF/Conversion/SimpleToMCFG.hs delete mode 100644 src/GF/Conversion/SimpleToMCFG/Coercions.hs delete mode 100644 src/GF/Conversion/SimpleToMCFG/Nondet.hs delete mode 100644 src/GF/Conversion/SimpleToMCFG/Strict.hs delete mode 100644 src/GF/Conversion/TypeGraph.hs delete mode 100644 src/GF/Conversion/Types.hs delete mode 100644 src/GF/Data/Assoc.hs delete mode 100644 src/GF/Data/BacktrackM.hs delete mode 100644 src/GF/Data/Compos.hs delete mode 100644 src/GF/Data/ErrM.hs delete mode 100644 src/GF/Data/GeneralDeduction.hs delete mode 100644 src/GF/Data/Glue.hs delete mode 100644 src/GF/Data/IncrementalDeduction.hs delete mode 100644 src/GF/Data/Map.hs delete mode 100644 src/GF/Data/Operations.hs delete mode 100644 src/GF/Data/OrdMap2.hs delete mode 100644 src/GF/Data/OrdSet.hs delete mode 100644 src/GF/Data/Parsers.hs delete mode 100644 src/GF/Data/RedBlack.hs delete mode 100644 src/GF/Data/RedBlackSet.hs delete mode 100644 src/GF/Data/SharedString.hs delete mode 100644 src/GF/Data/SortedList.hs delete mode 100644 src/GF/Data/Str.hs delete mode 100644 src/GF/Data/Trie.hs delete mode 100644 src/GF/Data/Trie2.hs delete mode 100644 src/GF/Data/Utilities.hs delete mode 100644 src/GF/Data/XML.hs delete mode 100644 src/GF/Data/Zipper.hs delete mode 100644 src/GF/Devel/AbsCompute.hs delete mode 100644 src/GF/Devel/Arch.hs delete mode 100644 src/GF/Devel/CheckGrammar.hs delete mode 100644 src/GF/Devel/CheckM.hs delete mode 100644 src/GF/Devel/Compile.hs delete mode 100644 src/GF/Devel/Compile/AbsGF.hs delete mode 100644 src/GF/Devel/Compile/CheckGrammar.hs delete mode 100644 src/GF/Devel/Compile/Compile.hs delete mode 100644 src/GF/Devel/Compile/ErrM.hs delete mode 100644 src/GF/Devel/Compile/Extend.hs delete mode 100644 src/GF/Devel/Compile/Factorize.hs delete mode 100644 src/GF/Devel/Compile/GF.cf delete mode 100644 src/GF/Devel/Compile/GFC.hs delete mode 100644 src/GF/Devel/Compile/GFtoGFCC.hs delete mode 100644 src/GF/Devel/Compile/GetGrammar.hs delete mode 100644 src/GF/Devel/Compile/LexGF.hs delete mode 100644 src/GF/Devel/Compile/Optimize.hs delete mode 100644 src/GF/Devel/Compile/ParGF.hs delete mode 100644 src/GF/Devel/Compile/PrintGF.hs delete mode 100644 src/GF/Devel/Compile/Refresh.hs delete mode 100644 src/GF/Devel/Compile/Rename.hs delete mode 100644 src/GF/Devel/Compile/SourceToGF.hs delete mode 100644 src/GF/Devel/Compute.hs delete mode 100644 src/GF/Devel/GF.hs delete mode 100644 src/GF/Devel/GFC.hs delete mode 100644 src/GF/Devel/GFC/Main.hs delete mode 100644 src/GF/Devel/GFCCInterpreter.hs delete mode 100644 src/GF/Devel/GFCCtoHaskell.hs delete mode 100644 src/GF/Devel/GFCCtoJS.hs delete mode 100644 src/GF/Devel/GFI.hs delete mode 100644 src/GF/Devel/GetGrammar.hs delete mode 100644 src/GF/Devel/Grammar/AppPredefined.hs delete mode 100644 src/GF/Devel/Grammar/Compute.hs delete mode 100644 src/GF/Devel/Grammar/Construct.hs delete mode 100644 src/GF/Devel/Grammar/GFtoSource.hs delete mode 100644 src/GF/Devel/Grammar/Grammar.hs delete mode 100644 src/GF/Devel/Grammar/Lookup.hs delete mode 100644 src/GF/Devel/Grammar/Macros.hs delete mode 100644 src/GF/Devel/Grammar/PatternMatch.hs delete mode 100644 src/GF/Devel/Grammar/PrGF.hs delete mode 100644 src/GF/Devel/GrammarToGFCC.hs delete mode 100644 src/GF/Devel/Infra/ReadFiles.hs delete mode 100644 src/GF/Devel/ModDeps.hs delete mode 100644 src/GF/Devel/Optimize.hs delete mode 100644 src/GF/Devel/OptimizeGF.hs delete mode 100644 src/GF/Devel/Options.hs delete mode 100644 src/GF/Devel/PrGrammar.hs delete mode 100644 src/GF/Devel/PrintGFCC.hs delete mode 100644 src/GF/Devel/README-testgf3 delete mode 100644 src/GF/Devel/ReadFiles.hs delete mode 100644 src/GF/Devel/TC.hs delete mode 100644 src/GF/Devel/TestGF3.hs delete mode 100644 src/GF/Devel/TypeCheck.hs delete mode 100644 src/GF/Devel/UseIO.hs delete mode 100644 src/GF/Devel/gf-code.txt delete mode 100644 src/GF/Devel/gf3.txt delete mode 100644 src/GF/Embed/EmbedAPI.hs delete mode 100644 src/GF/Embed/EmbedCustom.hs delete mode 100644 src/GF/Embed/EmbedParsing.hs delete mode 100644 src/GF/Embed/TemplateApp.hs delete mode 100644 src/GF/Formalism/CFG.hs delete mode 100644 src/GF/Formalism/FCFG.hs delete mode 100644 src/GF/Formalism/GCFG.hs delete mode 100644 src/GF/Formalism/MCFG.hs delete mode 100644 src/GF/Formalism/SimpleGFC.hs delete mode 100644 src/GF/Formalism/Utilities.hs delete mode 100644 src/GF/Fudgets/ArchEdit.hs delete mode 100644 src/GF/Fudgets/CommandF.hs delete mode 100644 src/GF/Fudgets/EventF.hs delete mode 100644 src/GF/Fudgets/FudgetOps.hs delete mode 100644 src/GF/Fudgets/UnicodeF.hs delete mode 100644 src/GF/GFCC/API.hs delete mode 100644 src/GF/GFCC/CId.hs delete mode 100644 src/GF/GFCC/CheckGFCC.hs delete mode 100644 src/GF/GFCC/ComposOp.hs delete mode 100644 src/GF/GFCC/DataGFCC.hs delete mode 100644 src/GF/GFCC/GFCC.cf delete mode 100644 src/GF/GFCC/Generate.hs delete mode 100644 src/GF/GFCC/LexGFCC.hs delete mode 100644 src/GF/GFCC/Linearize.hs delete mode 100644 src/GF/GFCC/Macros.hs delete mode 100644 src/GF/GFCC/OptimizeGFCC.hs delete mode 100644 src/GF/GFCC/Raw/AbsGFCCRaw.hs delete mode 100644 src/GF/GFCC/Raw/ConvertGFCC.hs delete mode 100644 src/GF/GFCC/Raw/GFCCRaw.cf delete mode 100644 src/GF/GFCC/Raw/ParGFCCRaw.hs delete mode 100644 src/GF/GFCC/Raw/PrintGFCCRaw.hs delete mode 100644 src/GF/GFCC/ShowLinearize.hs delete mode 100644 src/GF/GFCC/SkelGFCC.hs delete mode 100644 src/GF/GFCC/TestGFCC.hs delete mode 100644 src/GF/GFCC/doc/Eng.gf delete mode 100644 src/GF/GFCC/doc/Ex.gf delete mode 100644 src/GF/GFCC/doc/Swe.gf delete mode 100644 src/GF/GFCC/doc/Test.gf delete mode 100644 src/GF/GFCC/doc/gfcc.html delete mode 100644 src/GF/GFCC/doc/gfcc.txt delete mode 100644 src/GF/GFCC/doc/old-GFCC.cf delete mode 100644 src/GF/GFCC/doc/old-gfcc.txt delete mode 100644 src/GF/GFCC/doc/syntax.txt delete mode 100644 src/GF/GFModes.hs delete mode 100644 src/GF/Grammar/AbsCompute.hs delete mode 100644 src/GF/Grammar/Abstract.hs delete mode 100644 src/GF/Grammar/AppPredefined.hs delete mode 100644 src/GF/Grammar/Compute.hs delete mode 100644 src/GF/Grammar/Grammar.hs delete mode 100644 src/GF/Grammar/Lockfield.hs delete mode 100644 src/GF/Grammar/LookAbs.hs delete mode 100644 src/GF/Grammar/Lookup.hs delete mode 100644 src/GF/Grammar/MMacros.hs delete mode 100644 src/GF/Grammar/Macros.hs delete mode 100644 src/GF/Grammar/PatternMatch.hs delete mode 100644 src/GF/Grammar/PrGrammar.hs delete mode 100644 src/GF/Grammar/Refresh.hs delete mode 100644 src/GF/Grammar/ReservedWords.hs delete mode 100644 src/GF/Grammar/SGrammar.hs delete mode 100644 src/GF/Grammar/TC.hs delete mode 100644 src/GF/Grammar/TypeCheck.hs delete mode 100644 src/GF/Grammar/Unify.hs delete mode 100644 src/GF/Grammar/Values.hs delete mode 100644 src/GF/IDE/IDECommands.hs delete mode 100644 src/GF/Infra/CheckM.hs delete mode 100644 src/GF/Infra/Comments.hs delete mode 100644 src/GF/Infra/CompactPrint.hs delete mode 100644 src/GF/Infra/Ident.hs delete mode 100644 src/GF/Infra/Modules.hs delete mode 100644 src/GF/Infra/Option.hs delete mode 100644 src/GF/Infra/Print.hs delete mode 100644 src/GF/Infra/PrintClass.hs delete mode 100644 src/GF/Infra/ReadFiles.hs delete mode 100644 src/GF/Infra/UseIO.hs delete mode 100644 src/GF/JavaScript/AbsJS.hs delete mode 100644 src/GF/JavaScript/JS.cf delete mode 100644 src/GF/JavaScript/LexJS.hs delete mode 100644 src/GF/JavaScript/LexJS.x delete mode 100644 src/GF/JavaScript/Makefile delete mode 100644 src/GF/JavaScript/ParJS.hs delete mode 100644 src/GF/JavaScript/ParJS.y delete mode 100644 src/GF/JavaScript/PrintJS.hs delete mode 100644 src/GF/JavaScript/SkelJS.hs delete mode 100644 src/GF/JavaScript/TestJS.hs delete mode 100644 src/GF/OldParsing/CFGrammar.hs delete mode 100644 src/GF/OldParsing/ConvertFiniteGFC.hs delete mode 100644 src/GF/OldParsing/ConvertFiniteSimple.hs delete mode 100644 src/GF/OldParsing/ConvertGFCtoMCFG.hs delete mode 100644 src/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs delete mode 100644 src/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs delete mode 100644 src/GF/OldParsing/ConvertGFCtoMCFG/Old.hs delete mode 100644 src/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs delete mode 100644 src/GF/OldParsing/ConvertGFCtoSimple.hs delete mode 100644 src/GF/OldParsing/ConvertGrammar.hs delete mode 100644 src/GF/OldParsing/ConvertMCFGtoCFG.hs delete mode 100644 src/GF/OldParsing/ConvertSimpleToMCFG.hs delete mode 100644 src/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs delete mode 100644 src/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs delete mode 100644 src/GF/OldParsing/ConvertSimpleToMCFG/Old.hs delete mode 100644 src/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs delete mode 100644 src/GF/OldParsing/GCFG.hs delete mode 100644 src/GF/OldParsing/GeneralChart.hs delete mode 100644 src/GF/OldParsing/GrammarTypes.hs delete mode 100644 src/GF/OldParsing/IncrementalChart.hs delete mode 100644 src/GF/OldParsing/MCFGrammar.hs delete mode 100644 src/GF/OldParsing/ParseCF.hs delete mode 100644 src/GF/OldParsing/ParseCFG.hs delete mode 100644 src/GF/OldParsing/ParseCFG/General.hs delete mode 100644 src/GF/OldParsing/ParseCFG/Incremental.hs delete mode 100644 src/GF/OldParsing/ParseGFC.hs delete mode 100644 src/GF/OldParsing/ParseMCFG.hs delete mode 100644 src/GF/OldParsing/ParseMCFG/Basic.hs delete mode 100644 src/GF/OldParsing/SimpleGFC.hs delete mode 100644 src/GF/OldParsing/Utilities.hs delete mode 100644 src/GF/Parsing/CF.hs delete mode 100644 src/GF/Parsing/CFG.hs delete mode 100644 src/GF/Parsing/CFG/General.hs delete mode 100644 src/GF/Parsing/CFG/Incremental.hs delete mode 100644 src/GF/Parsing/CFG/PInfo.hs delete mode 100644 src/GF/Parsing/FCFG.hs delete mode 100644 src/GF/Parsing/FCFG/Active.hs delete mode 100644 src/GF/Parsing/FCFG/Incremental.hs delete mode 100644 src/GF/Parsing/FCFG/PInfo.hs delete mode 100644 src/GF/Parsing/FCFG/Range.hs delete mode 100644 src/GF/Parsing/GFC.hs delete mode 100644 src/GF/Parsing/MCFG.hs delete mode 100644 src/GF/Parsing/MCFG/Active.hs delete mode 100644 src/GF/Parsing/MCFG/Active2.hs delete mode 100644 src/GF/Parsing/MCFG/FastActive.hs delete mode 100644 src/GF/Parsing/MCFG/Incremental.hs delete mode 100644 src/GF/Parsing/MCFG/Incremental2.hs delete mode 100644 src/GF/Parsing/MCFG/Naive.hs delete mode 100644 src/GF/Parsing/MCFG/PInfo.hs delete mode 100644 src/GF/Parsing/MCFG/Range.hs delete mode 100644 src/GF/Parsing/MCFG/ViaCFG.hs delete mode 100644 src/GF/Printing/PrintParser.hs delete mode 100644 src/GF/Printing/PrintSimplifiedTerm.hs delete mode 100644 src/GF/Probabilistic/Probabilistic.hs delete mode 100644 src/GF/Shell.hs delete mode 100644 src/GF/Shell/CommandL.hs delete mode 100644 src/GF/Shell/Commands.hs delete mode 100644 src/GF/Shell/HelpFile.hs delete mode 100644 src/GF/Shell/JGF.hs delete mode 100644 src/GF/Shell/PShell.hs delete mode 100644 src/GF/Shell/ShellCommands.hs delete mode 100644 src/GF/Shell/SubShell.hs delete mode 100644 src/GF/Shell/TeachYourself.hs delete mode 100644 src/GF/Source/AbsGF.hs delete mode 100644 src/GF/Source/ErrM.hs delete mode 100644 src/GF/Source/GF.cf delete mode 100644 src/GF/Source/GrammarToSource.hs delete mode 100644 src/GF/Source/LexGF.hs delete mode 100644 src/GF/Source/LexGF.x delete mode 100644 src/GF/Source/ParGF.hs delete mode 100644 src/GF/Source/ParGF.y delete mode 100644 src/GF/Source/PrintGF.hs delete mode 100644 src/GF/Source/SkelGF.hs delete mode 100644 src/GF/Source/SourceToGrammar.hs delete mode 100644 src/GF/Source/TestGF.hs delete mode 100644 src/GF/Speech/CFGToFiniteState.hs delete mode 100644 src/GF/Speech/FiniteState.hs delete mode 100644 src/GF/Speech/GrammarToVoiceXML.hs delete mode 100644 src/GF/Speech/Graph.hs delete mode 100644 src/GF/Speech/PrFA.hs delete mode 100644 src/GF/Speech/PrGSL.hs delete mode 100644 src/GF/Speech/PrJSGF.hs delete mode 100644 src/GF/Speech/PrRegExp.hs delete mode 100644 src/GF/Speech/PrSLF.hs delete mode 100644 src/GF/Speech/PrSRGS.hs delete mode 100644 src/GF/Speech/PrSRGS_ABNF.hs delete mode 100644 src/GF/Speech/RegExp.hs delete mode 100644 src/GF/Speech/Relation.hs delete mode 100644 src/GF/Speech/RelationQC.hs delete mode 100644 src/GF/Speech/SISR.hs delete mode 100644 src/GF/Speech/SRG.hs delete mode 100644 src/GF/Speech/TransformCFG.hs delete mode 100644 src/GF/System/ATKSpeechInput.hs delete mode 100644 src/GF/System/Arch.hs delete mode 100644 src/GF/System/ArchEdit.hs delete mode 100644 src/GF/System/NoReadline.hs delete mode 100644 src/GF/System/NoSignal.hs delete mode 100644 src/GF/System/NoSpeechInput.hs delete mode 100644 src/GF/System/Readline.hs delete mode 100644 src/GF/System/Signal.hs delete mode 100644 src/GF/System/SpeechInput.hs delete mode 100644 src/GF/System/Tracing.hs delete mode 100644 src/GF/System/UseReadline.hs delete mode 100644 src/GF/System/UseSignal.hs delete mode 100644 src/GF/Text/Arabic.hs delete mode 100644 src/GF/Text/Devanagari.hs delete mode 100644 src/GF/Text/Ethiopic.hs delete mode 100644 src/GF/Text/ExtendedArabic.hs delete mode 100644 src/GF/Text/ExtraDiacritics.hs delete mode 100644 src/GF/Text/Greek.hs delete mode 100644 src/GF/Text/Hebrew.hs delete mode 100644 src/GF/Text/Hiragana.hs delete mode 100644 src/GF/Text/LatinASupplement.hs delete mode 100644 src/GF/Text/OCSCyrillic.hs delete mode 100644 src/GF/Text/Russian.hs delete mode 100644 src/GF/Text/Tamil.hs delete mode 100644 src/GF/Text/Text.hs delete mode 100644 src/GF/Text/Thai.hs delete mode 100644 src/GF/Text/UTF8.hs delete mode 100644 src/GF/Text/Unicode.hs delete mode 100644 src/GF/Translate/GFT.hs delete mode 100644 src/GF/UseGrammar/Custom.hs delete mode 100644 src/GF/UseGrammar/Editing.hs delete mode 100644 src/GF/UseGrammar/Generate.hs delete mode 100644 src/GF/UseGrammar/GetTree.hs delete mode 100644 src/GF/UseGrammar/Information.hs delete mode 100644 src/GF/UseGrammar/Linear.hs delete mode 100644 src/GF/UseGrammar/MatchTerm.hs delete mode 100644 src/GF/UseGrammar/Morphology.hs delete mode 100644 src/GF/UseGrammar/Paraphrases.hs delete mode 100644 src/GF/UseGrammar/Parsing.hs delete mode 100644 src/GF/UseGrammar/Randomized.hs delete mode 100644 src/GF/UseGrammar/Session.hs delete mode 100644 src/GF/UseGrammar/Statistics.hs delete mode 100644 src/GF/UseGrammar/Tokenize.hs delete mode 100644 src/GF/UseGrammar/Transfer.hs delete mode 100644 src/GF/UseGrammar/TreeSelections.hs delete mode 100644 src/GF/UseGrammar/Treebank.hs delete mode 100644 src/GF/Visualization/Graphviz.hs delete mode 100644 src/GF/Visualization/VisualizeGrammar.hs delete mode 100644 src/GF/Visualization/VisualizeTree.hs (limited to 'src/GF') diff --git a/src/GF/API.hs b/src/GF/API.hs deleted file mode 100644 index b1deeddfc..000000000 --- a/src/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/GF/API/BatchTranslate.hs b/src/GF/API/BatchTranslate.hs deleted file mode 100644 index c1b124526..000000000 --- a/src/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/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs deleted file mode 100644 index c57cfed42..000000000 --- a/src/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/GF/API/GrammarToTransfer.hs b/src/GF/API/GrammarToTransfer.hs deleted file mode 100644 index 658c15184..000000000 --- a/src/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/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs deleted file mode 100644 index bd7fc5648..000000000 --- a/src/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/GF/API/MyParser.hs b/src/GF/API/MyParser.hs deleted file mode 100644 index c926fe865..000000000 --- a/src/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/GF/CF/CF.hs b/src/GF/CF/CF.hs deleted file mode 100644 index 9233e905a..000000000 --- a/src/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/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs deleted file mode 100644 index 02ee482c0..000000000 --- a/src/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/GF/CF/CFtoGrammar.hs b/src/GF/CF/CFtoGrammar.hs deleted file mode 100644 index 5e73aec31..000000000 --- a/src/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 (mkIdent "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/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs deleted file mode 100644 index 80ce2e79d..000000000 --- a/src/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/GF/CF/ChartParser.hs b/src/GF/CF/ChartParser.hs deleted file mode 100644 index 740c4d787..000000000 --- a/src/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/GF/CF/EBNF.hs b/src/GF/CF/EBNF.hs deleted file mode 100644 index f091d19cb..000000000 --- a/src/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/GF/CF/PPrCF.hs b/src/GF/CF/PPrCF.hs deleted file mode 100644 index 1c2203e94..000000000 --- a/src/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/GF/CF/PrLBNF.hs b/src/GF/CF/PrLBNF.hs deleted file mode 100644 index 4ba2019bc..000000000 --- a/src/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/GF/CF/Profile.hs b/src/GF/CF/Profile.hs deleted file mode 100644 index e573bec78..000000000 --- a/src/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/GF/CFGM/AbsCFG.hs b/src/GF/CFGM/AbsCFG.hs deleted file mode 100644 index 063b96802..000000000 --- a/src/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/GF/CFGM/CFG.cf b/src/GF/CFGM/CFG.cf deleted file mode 100644 index fa722f4a4..000000000 --- a/src/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/GF/CFGM/LexCFG.hs b/src/GF/CFGM/LexCFG.hs deleted file mode 100644 index e58fdff5a..000000000 --- a/src/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/GF/CFGM/LexCFG.x b/src/GF/CFGM/LexCFG.x deleted file mode 100644 index f3ecb14eb..000000000 --- a/src/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/GF/CFGM/ParCFG.hs b/src/GF/CFGM/ParCFG.hs deleted file mode 100644 index cb70ef30d..000000000 --- a/src/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/GF/CFGM/ParCFG.y b/src/GF/CFGM/ParCFG.y deleted file mode 100644 index 7b3041b3b..000000000 --- a/src/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/GF/CFGM/PrintCFG.hs b/src/GF/CFGM/PrintCFG.hs deleted file mode 100644 index 0fd46239c..000000000 --- a/src/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/GF/CFGM/PrintCFGrammar.hs b/src/GF/CFGM/PrintCFGrammar.hs deleted file mode 100644 index a68d2325c..000000000 --- a/src/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/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs deleted file mode 100644 index 8ce719104..000000000 --- a/src/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/GF/Canon/AbsToBNF.hs b/src/GF/Canon/AbsToBNF.hs deleted file mode 100644 index e30e836da..000000000 --- a/src/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/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs deleted file mode 100644 index 572f09763..000000000 --- a/src/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/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs deleted file mode 100644 index 044ea3669..000000000 --- a/src/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/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs deleted file mode 100644 index 078c3cc03..000000000 --- a/src/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/GF/Canon/GFC.cf b/src/GF/Canon/GFC.cf deleted file mode 100644 index d9385a49f..000000000 --- a/src/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/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs deleted file mode 100644 index ae9097c44..000000000 --- a/src/GF/Canon/GFC.hs +++ /dev/null @@ -1,103 +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 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' /= 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 f) (identC 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/GF/Canon/GetGFC.hs b/src/GF/Canon/GetGFC.hs deleted file mode 100644 index 049f75efe..000000000 --- a/src/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/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs deleted file mode 100644 index 31a4a9b30..000000000 --- a/src/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/GF/Canon/LexGFC.x b/src/GF/Canon/LexGFC.x deleted file mode 100644 index 0a50e49d1..000000000 --- a/src/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/GF/Canon/Look.hs b/src/GF/Canon/Look.hs deleted file mode 100644 index a93d4c834..000000000 --- a/src/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/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs deleted file mode 100644 index 8443354fc..000000000 --- a/src/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/GF/Canon/ParGFC.hs b/src/GF/Canon/ParGFC.hs deleted file mode 100644 index 4332c06e4..000000000 --- a/src/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/GF/Canon/ParGFC.y b/src/GF/Canon/ParGFC.y deleted file mode 100644 index 6432a8696..000000000 --- a/src/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/GF/Canon/PrExp.hs b/src/GF/Canon/PrExp.hs deleted file mode 100644 index 6202a760e..000000000 --- a/src/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/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs deleted file mode 100644 index 437f3a1e9..000000000 --- a/src/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/GF/Canon/Share.hs b/src/GF/Canon/Share.hs deleted file mode 100644 index 69725001a..000000000 --- a/src/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/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs deleted file mode 100644 index a1d9331d8..000000000 --- a/src/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/GF/Canon/Subexpressions.hs b/src/GF/Canon/Subexpressions.hs deleted file mode 100644 index 683f9eecf..000000000 --- a/src/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/GF/Canon/TestGFC.hs b/src/GF/Canon/TestGFC.hs deleted file mode 100644 index 7c89d64e8..000000000 --- a/src/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/GF/Canon/Unlex.hs b/src/GF/Canon/Unlex.hs deleted file mode 100644 index dd93390e2..000000000 --- a/src/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/GF/Canon/Unparametrize.hs b/src/GF/Canon/Unparametrize.hs deleted file mode 100644 index 0ca6a2d9c..000000000 --- a/src/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/GF/Canon/log.txt b/src/GF/Canon/log.txt deleted file mode 100644 index 44dba3954..000000000 --- a/src/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/GF/Command/AbsGFShell.hs b/src/GF/Command/AbsGFShell.hs deleted file mode 100644 index c13004cf9..000000000 --- a/src/GF/Command/AbsGFShell.hs +++ /dev/null @@ -1,42 +0,0 @@ -module GF.Command.AbsGFShell where - --- Haskell module generated by the BNF converter - -newtype Ident = Ident String deriving (Eq,Ord,Show) -data CommandLine = - CLine [Pipe] - | CEmpty - deriving (Eq,Ord,Show) - -data Pipe = - PComm [Command] - deriving (Eq,Ord,Show) - -data Command = - Comm Ident [Option] Argument - | CNoarg Ident [Option] - deriving (Eq,Ord,Show) - -data Option = - OOpt Ident - | OFlag Ident Value - deriving (Eq,Ord,Show) - -data Value = - VId Ident - | VInt Integer - deriving (Eq,Ord,Show) - -data Argument = - ATree Tree - deriving (Eq,Ord,Show) - -data Tree = - TApp Ident [Tree] - | TAbs [Ident] Tree - | TId Ident - | TInt Integer - | TStr String - | TFloat Double - deriving (Eq,Ord,Show) - diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs deleted file mode 100644 index d5b5a8768..000000000 --- a/src/GF/Command/Commands.hs +++ /dev/null @@ -1,159 +0,0 @@ -module GF.Command.Commands ( - allCommands, - lookCommand, - exec, - isOpt, - options, - flags, - CommandInfo, - CommandOutput - ) where - -import GF.Command.AbsGFShell hiding (Tree) -import GF.Command.PPrTree -import GF.Command.ParGFShell -import GF.GFCC.ShowLinearize -import GF.GFCC.API -import GF.GFCC.Macros -import GF.Devel.PrintGFCC -import GF.GFCC.DataGFCC ---- - -import GF.Data.ErrM ---- - -import qualified Data.Map as Map - -type CommandOutput = ([Tree],String) ---- errors, etc - -data CommandInfo = CommandInfo { - exec :: [Option] -> [Tree] -> IO CommandOutput, - synopsis :: String, - explanation :: String, - longname :: String, - options :: [String], - flags :: [String] - } - -emptyCommandInfo :: CommandInfo -emptyCommandInfo = CommandInfo { - exec = \_ ts -> return (ts,[]), ---- - synopsis = "synopsis", - explanation = "explanation", - longname = "longname", - options = [], - flags = [] - } - -lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo -lookCommand = Map.lookup - -commandHelpAll :: MultiGrammar -> [Option] -> String -commandHelpAll mgr opts = unlines - [commandHelp (isOpt "full" opts) (co,info) - | (co,info) <- Map.assocs (allCommands mgr)] - -commandHelp :: Bool -> (String,CommandInfo) -> String -commandHelp full (co,info) = unlines $ [ - co ++ ", " ++ longname info, - synopsis info] ++ if full then [ - explanation info, - "options: " ++ unwords (options info), - "flags: " ++ unwords (flags info) - ] else [] - -valIdOpts :: String -> String -> [Option] -> String -valIdOpts flag def opts = case valOpts flag (VId (Ident def)) opts of - VId (Ident v) -> v - _ -> def - -valIntOpts :: String -> Integer -> [Option] -> Int -valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of - VInt v -> v - _ -> def - -valOpts :: String -> Value -> [Option] -> Value -valOpts flag def opts = case lookup flag flags of - Just v -> v - _ -> def - where - flags = [(f,v) | OFlag (Ident f) v <- opts] - -isOpt :: String -> [Option] -> Bool -isOpt o opts = elem o [x | OOpt (Ident x) <- opts] - --- this list must be kept sorted by the command name! -allCommands :: MultiGrammar -> Map.Map String CommandInfo -allCommands mgr = Map.fromAscList [ - ("gr", emptyCommandInfo { - longname = "generate_random", - synopsis = "generates a list of random trees, by default one tree", - flags = ["cat","number"], - exec = \opts _ -> do - ts <- generateRandom mgr (optCat opts) - return $ fromTrees $ take (optNum opts) ts - }), - ("gt", emptyCommandInfo { - longname = "generate_trees", - synopsis = "generates a list of trees, by default exhaustive", - flags = ["cat","depth","number"], - exec = \opts _ -> do - let dp = return $ valIntOpts "depth" 4 opts - let ts = generateAllDepth mgr (optCat opts) dp - return $ fromTrees $ take (optNumInf opts) ts - }), - ("h", emptyCommandInfo { - longname = "help", - synopsis = "get description of a command, or a the full list of commands", - options = ["full"], - exec = \opts ts -> return ([], case ts of - [t] -> let co = (showTree t) in - case lookCommand co (allCommands mgr) of ---- new map ??!! - Just info -> commandHelp True (co,info) - _ -> "command not found" - _ -> commandHelpAll mgr opts) - }), - ("l", emptyCommandInfo { - exec = \opts -> return . fromStrings . map (optLin opts), - options = ["all","record","table","term"], - flags = ["lang"] - }), - ("p", emptyCommandInfo { - exec = \opts -> return . fromTrees . concatMap (par opts). toStrings, - flags = ["cat","lang"] - }), - ("pg", emptyCommandInfo { - exec = \opts _ -> return $ fromString $ prGrammar opts, - flags = ["cat","lang","printer"] - }) - ] - where - lin opts t = unlines [linearize mgr lang t | lang <- optLangs opts] - par opts s = concat [parse mgr lang (optCat opts) s | lang <- optLangs opts] - - optLin opts t = unlines [linea lang t | lang <- optLangs opts] where - linea lang = case opts of - _ | isOpt "all" opts -> allLinearize gr (cid lang) - _ | isOpt "table" opts -> tableLinearize gr (cid lang) - _ | isOpt "term" opts -> termLinearize gr (cid lang) - _ | isOpt "record" opts -> recordLinearize gr (cid lang) - _ -> linearize mgr lang - - - optLangs opts = case valIdOpts "lang" "" opts of - "" -> languages mgr - lang -> [lang] - optCat opts = valIdOpts "cat" (lookStartCat gr) opts - optNum opts = valIntOpts "number" 1 opts - optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 - - gr = gfcc mgr - - fromTrees ts = (ts,unlines (map showTree ts)) - fromStrings ss = (map tStr ss, unlines ss) - fromString s = ([tStr s], s) - toStrings ts = [s | DTr [] (AS s) [] <- ts] - tStr s = DTr [] (AS s) [] - - prGrammar opts = case valIdOpts "printer" "" opts of - "cats" -> unwords $ categories mgr - v -> prGFCC v gr - diff --git a/src/GF/Command/GFShell.cf b/src/GF/Command/GFShell.cf deleted file mode 100644 index 1f5a9fa6d..000000000 --- a/src/GF/Command/GFShell.cf +++ /dev/null @@ -1,27 +0,0 @@ ---entrypoints CommandLine, Tree ; - -CLine. CommandLine ::= [Pipe] ; -CEmpty. CommandLine ::= ; -PComm. Pipe ::= [Command] ; -Comm. Command ::= Ident [Option] Argument ; -CNoarg. Command ::= Ident [Option] ; -OOpt. Option ::= "-" Ident ; -OFlag. Option ::= "-" Ident "=" Value ; -VId. Value ::= Ident ; -VInt. Value ::= Integer ; -ATree. Argument ::= Tree ; - -TApp. Tree1 ::= Ident [Tree2] ; -TAbs. Tree ::= "\\" [Ident] "->" Tree ; -TId. Tree2 ::= Ident ; -TInt. Tree2 ::= Integer ; -TStr. Tree2 ::= String ; -TFloat. Tree2 ::= Double ; - -coercions Tree 2 ; - -separator nonempty Pipe ";" ; -separator nonempty Command "|" ; -terminator Option "" ; -terminator nonempty Tree2 "" ; -terminator nonempty Ident "," ; diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs deleted file mode 100644 index a09ba8de6..000000000 --- a/src/GF/Command/Importing.hs +++ /dev/null @@ -1,28 +0,0 @@ -module GF.Command.Importing (importGrammar) where - -import GF.Compile.API -import GF.GFCC.DataGFCC -import GF.GFCC.API - -import GF.Devel.UseIO -import GF.Infra.Option -import GF.Data.ErrM - -import Data.List (nubBy) -import System.FilePath - --- import a grammar in an environment where it extends an existing grammar -importGrammar :: MultiGrammar -> Options -> [FilePath] -> IO MultiGrammar -importGrammar mgr0 opts files = - case takeExtensions (last files) of - s | elem s [".gf",".gfo"] -> do - res <- appIOE $ compileToGFCC opts files - case res of - Ok gfcc2 -> do let gfcc3 = unionGFCC (gfcc mgr0) gfcc2 - return $ MultiGrammar gfcc3 - Bad msg -> do putStrLn msg - return mgr0 - ".gfcc" -> do - gfcc2 <- mapM file2gfcc files >>= return . foldl1 unionGFCC - let gfcc3 = unionGFCC (gfcc mgr0) gfcc2 - return $ MultiGrammar gfcc3 \ No newline at end of file diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs deleted file mode 100644 index 10730e7ef..000000000 --- a/src/GF/Command/Interpreter.hs +++ /dev/null @@ -1,74 +0,0 @@ -module GF.Command.Interpreter ( - CommandEnv (..), - interpretCommandLine - ) where - -import GF.Command.Commands -import GF.Command.AbsGFShell hiding (Tree) -import GF.Command.PPrTree -import GF.Command.ParGFShell -import GF.GFCC.API -import GF.GFCC.Macros -import GF.GFCC.DataGFCC - -import GF.Data.ErrM ---- - -import qualified Data.Map as Map - -data CommandEnv = CommandEnv { - multigrammar :: MultiGrammar, - commands :: Map.Map String CommandInfo - } - -interpretCommandLine :: CommandEnv -> String -> IO () -interpretCommandLine env line = case (pCommandLine (myLexer line)) of - Ok CEmpty -> return () - Ok (CLine pipes) -> mapM_ interPipe pipes - _ -> putStrLn "command not parsed" - where - interPipe (PComm cs) = do - (_,s) <- intercs ([],"") cs - putStrLn s - intercs treess [] = return treess - intercs (trees,_) (c:cs) = do - treess2 <- interc trees c - intercs treess2 cs - interc = interpret env - --- return the trees to be sent in pipe, and the output possibly printed -interpret :: CommandEnv -> [Tree] -> Command -> IO CommandOutput -interpret env trees0 comm = case lookCommand co comms of - Just info -> do - checkOpts info - tss@(_,s) <- exec info opts trees - optTrace s - return tss - _ -> do - putStrLn $ "command " ++ co ++ " not interpreted" - return ([],[]) - where - optTrace = if isOpt "tr" opts then putStrLn else const (return ()) - (co,opts,trees) = getCommand comm trees0 - comms = commands env - checkOpts info = - case - [o | OOpt (Ident o) <- opts, notElem o (options info)] ++ - [o | OFlag (Ident o) _ <- opts, notElem o (flags info)] - of - [] -> return () - [o] -> putStrLn $ "option not interpreted: " ++ o - os -> putStrLn $ "options not interpreted: " ++ unwords os - --- analyse command parse tree to a uniform datastructure, normalizing comm name -getCommand :: Command -> [Tree] -> (String,[Option],[Tree]) -getCommand co ts = case co of - Comm (Ident c) opts (ATree t) -> (getOp c,opts,[tree2exp t]) -- ignore piped - CNoarg (Ident c) opts -> (getOp c,opts,ts) -- use piped - where - -- abbreviation convention from gf - getOp s = case break (=='_') s of - (a:_,_:b:_) -> [a,b] -- axx_byy --> ab - _ -> case s of - [a,b] -> s -- ab --> ab - a:_ -> [a] -- axx --> a - diff --git a/src/GF/Command/LexGFShell.hs b/src/GF/Command/LexGFShell.hs deleted file mode 100644 index 8e0191039..000000000 --- a/src/GF/Command/LexGFShell.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "GF/Command/LexGFShell.x" #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Command.LexGFShell 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# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\xd2\xff\xff\xff\xc8\x00\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x43\x01\x00\x00\x31\x00\x00\x00\x4e\x00\x00\x00\x13\x01\x00\x00\x76\x00\x00\x00\x1e\x01\x00\x00\x2b\x01\x00\x00\x36\x01\x00\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\x08\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x03\x00\x02\x00\x00\x00\x03\x00\x04\x00\x00\x00\x00\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x00\x00\x03\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x09\x00\x03\x00\x00\x00\x00\x00\x00\x00\x09\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\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\x07\x00\x00\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\x00\x00\x09\x00\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\x00\x00\x00\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x0a\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x06\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\xff\xff\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x10\x00\x00\x00\x00\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x07\x00\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\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x0a\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\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\xff\xff\x28\x00\x29\x00\x20\x00\xff\xff\x2c\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\x3b\x00\xff\xff\x3d\x00\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\x5c\x00\xff\xff\xff\xff\xff\xff\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\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\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\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\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\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\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\x22\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\xff\xff\x65\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\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\xff\xff\xff\xff\x09\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,16) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]] -{-# LINE 32 "GF/Command/LexGFShell.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 = 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 -> 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/GF/Command/PPrTree.hs b/src/GF/Command/PPrTree.hs deleted file mode 100644 index 7372c722d..000000000 --- a/src/GF/Command/PPrTree.hs +++ /dev/null @@ -1,39 +0,0 @@ -module GF.Command.PPrTree (pTree, prExp, tree2exp) where - -import GF.GFCC.DataGFCC -import GF.GFCC.CId -import GF.GFCC.Macros -import qualified GF.Command.ParGFShell as P -import GF.Command.PrintGFShell -import GF.Command.AbsGFShell -import GF.Data.ErrM - -pTree :: String -> Exp -pTree s = case P.pTree (P.myLexer s) of - Ok t -> tree2exp t - Bad s -> error s - -tree2exp t = case t of - TApp f ts -> tree (AC (i2i f)) (map tree2exp ts) - TAbs xs t -> DTr (map i2i xs ++ ys) f ts where DTr ys f ts = tree2exp t - TId c -> tree (AC (i2i c)) [] - TInt i -> tree (AI i) [] - TStr s -> tree (AS s) [] - TFloat d -> tree (AF d) [] - where - i2i (Ident s) = CId s - -prExp :: Exp -> String -prExp = printTree . exp2tree - -exp2tree (DTr xs at ts) = tabs (map i4i xs) (tapp at (map exp2tree ts)) - where - tabs [] t = t - tabs ys t = TAbs ys t - tapp (AC f) [] = TId (i4i f) - tapp (AC f) vs = TApp (i4i f) vs - tapp (AI i) [] = TInt i - tapp (AS i) [] = TStr i - tapp (AF i) [] = TFloat i - tapp (AM i) [] = TId (Ident "?") ---- - i4i (CId s) = Ident s diff --git a/src/GF/Command/ParGFShell.hs b/src/GF/Command/ParGFShell.hs deleted file mode 100644 index 1fc85b4b7..000000000 --- a/src/GF/Command/ParGFShell.hs +++ /dev/null @@ -1,809 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module GF.Command.ParGFShell where -import GF.Command.AbsGFShell -import GF.Command.LexGFShell -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 (() -> ()) -happyIn17 :: (Ident) -> (HappyAbsSyn ) -happyIn17 x = unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> (Ident) -happyOut17 x = unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Integer) -> (HappyAbsSyn ) -happyIn18 x = unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (Integer) -happyOut18 x = unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: (String) -> (HappyAbsSyn ) -happyIn19 x = unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (String) -happyOut19 x = unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (Double) -> (HappyAbsSyn ) -happyIn20 x = unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Double) -happyOut20 x = unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (CommandLine) -> (HappyAbsSyn ) -happyIn21 x = unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (CommandLine) -happyOut21 x = unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Pipe) -> (HappyAbsSyn ) -happyIn22 x = unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Pipe) -happyOut22 x = unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: (Command) -> (HappyAbsSyn ) -happyIn23 x = unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> (Command) -happyOut23 x = unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (Option) -> (HappyAbsSyn ) -happyIn24 x = unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Option) -happyOut24 x = unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: (Value) -> (HappyAbsSyn ) -happyIn25 x = unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> (Value) -happyOut25 x = unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Argument) -> (HappyAbsSyn ) -happyIn26 x = unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Argument) -happyOut26 x = unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: (Tree) -> (HappyAbsSyn ) -happyIn27 x = unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> (Tree) -happyOut27 x = unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (Tree) -> (HappyAbsSyn ) -happyIn28 x = unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (Tree) -happyOut28 x = unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: (Tree) -> (HappyAbsSyn ) -happyIn29 x = unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (Tree) -happyOut29 x = unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: ([Pipe]) -> (HappyAbsSyn ) -happyIn30 x = unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> ([Pipe]) -happyOut30 x = unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: ([Command]) -> (HappyAbsSyn ) -happyIn31 x = unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> ([Command]) -happyOut31 x = unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: ([Option]) -> (HappyAbsSyn ) -happyIn32 x = unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> ([Option]) -happyOut32 x = unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: ([Tree]) -> (HappyAbsSyn ) -happyIn33 x = unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> ([Tree]) -happyOut33 x = unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: ([Ident]) -> (HappyAbsSyn ) -happyIn34 x = unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> ([Ident]) -happyOut34 x = unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x8d\x00\x8d\x00\x8d\x00\x91\x00\x16\x00\x80\x00\x89\x00\x80\x00\x89\x00\x7c\x00\x7c\x00\x00\x00\x89\x00\x7c\x00\x7c\x00\x00\x00\x7b\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x73\x00\x80\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x79\x00\x6c\x00\x72\x00\x69\x00\x00\x00\x69\x00\x89\x00\x00\x00\x69\x00\x00\x00\x62\x00\x5f\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x5f\x00\x5d\x00\x54\x00\x54\x00\x54\x00\x00\x00\x60\x00\x52\x00\x00\x00\x3a\x00\x3a\x00\x6a\x00\x00\x00\x24\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x16\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x1f\x00\x09\x00\x35\x00\x2a\x00\x90\x00\x49\x00\x70\x00\x5e\x00\x7d\x00\x33\x00\x34\x00\x42\x00\x1b\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x12\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x22\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x87\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\xff\x00\x00\x00\x00\x00\x00\xf1\xff\x00\x00\x00\x00\xdf\xff\xde\xff\xdd\xff\xdc\xff\xd4\xff\x00\x00\x00\x00\xf0\xff\xef\xff\xee\xff\x00\x00\xd6\xff\xd8\xff\x00\x00\xda\xff\x00\x00\xeb\xff\x00\x00\xdf\xff\xe0\xff\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\xe4\xff\xe6\xff\xe5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xe8\xff\x00\x00\xe3\xff\x00\x00\x00\x00\xe9\xff\xd5\xff\x00\x00\xd3\xff\xd2\xff\xd1\xff\xdb\xff\xea\xff\xd7\xff\xd9\xff\x00\x00\x00\x00\xe7\xff\xe1\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x05\x00\x06\x00\x0a\x00\x0c\x00\x11\x00\x11\x00\x11\x00\x10\x00\x0c\x00\x0e\x00\x01\x00\x07\x00\x10\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x0a\x00\x0b\x00\x00\x00\x04\x00\x05\x00\x06\x00\x0f\x00\x0c\x00\x06\x00\x00\x00\x06\x00\x10\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x0e\x00\x07\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x06\x00\x06\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0d\x00\x0e\x00\x0e\x00\x07\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x04\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x0f\x00\x0a\x00\x0b\x00\x0c\x00\x0a\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x0a\x00\x03\x00\x0f\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0f\x00\x07\x00\x0a\x00\x0f\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x08\x00\x0f\x00\x03\x00\x09\x00\x05\x00\x0a\x00\x00\x00\x01\x00\x0c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x08\x00\x00\x00\x01\x00\x01\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x08\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"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x10\x00\x10\x00\x10\x00\x35\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1d\x00\x12\x00\x13\x00\x14\x00\x15\x00\x32\x00\x1e\x00\x10\x00\x16\x00\x3f\x00\x36\x00\x11\x00\x37\x00\x16\x00\x22\x00\x31\x00\x3b\x00\x3d\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1d\x00\x10\x00\x1a\x00\x1d\x00\x33\x00\x20\x00\x1e\x00\xff\xff\x16\x00\x1e\x00\x1d\x00\x41\x00\x17\x00\x34\x00\x22\x00\x20\x00\x1e\x00\x42\x00\x2f\x00\x3a\x00\x1d\x00\x1d\x00\x1d\x00\x43\x00\x22\x00\x20\x00\x1e\x00\x1e\x00\x31\x00\x24\x00\x13\x00\x14\x00\x15\x00\x21\x00\x22\x00\x1f\x00\x3b\x00\x10\x00\x41\x00\x25\x00\x2b\x00\x27\x00\x24\x00\x13\x00\x14\x00\x15\x00\x24\x00\x13\x00\x14\x00\x15\x00\x1c\x00\x2a\x00\x25\x00\x2b\x00\x27\x00\x45\x00\x25\x00\x47\x00\x27\x00\x24\x00\x13\x00\x14\x00\x15\x00\x24\x00\x13\x00\x14\x00\x15\x00\x46\x00\xff\xff\x25\x00\x3c\x00\x27\x00\x10\x00\x25\x00\x26\x00\x27\x00\x31\x00\x10\x00\x29\x00\xff\xff\x19\x00\x24\x00\x13\x00\x14\x00\x15\x00\x10\x00\x1a\x00\x1b\x00\x1c\x00\xff\xff\x39\x00\x29\x00\xff\xff\x27\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3a\x00\xff\xff\x29\x00\x3f\x00\x19\x00\x10\x00\x2c\x00\x2d\x00\x23\x00\x10\x00\x1a\x00\x1b\x00\x1c\x00\x19\x00\x46\x00\x2c\x00\x2d\x00\x31\x00\x10\x00\x1a\x00\x1b\x00\x1c\x00\x10\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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 (14, 46) [ - (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) - ] - -happy_n_terms = 16 :: Int -happy_n_nonterms = 18 :: Int - -happyReduce_14 = happySpecReduce_1 0# happyReduction_14 -happyReduction_14 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> - happyIn17 - (Ident happy_var_1 - )} - -happyReduce_15 = happySpecReduce_1 1# happyReduction_15 -happyReduction_15 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn18 - ((read happy_var_1) :: Integer - )} - -happyReduce_16 = happySpecReduce_1 2# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn19 - (happy_var_1 - )} - -happyReduce_17 = happySpecReduce_1 3# happyReduction_17 -happyReduction_17 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> - happyIn20 - ((read happy_var_1) :: Double - )} - -happyReduce_18 = happySpecReduce_1 4# happyReduction_18 -happyReduction_18 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn21 - (CLine happy_var_1 - )} - -happyReduce_19 = happySpecReduce_0 4# happyReduction_19 -happyReduction_19 = happyIn21 - (CEmpty - ) - -happyReduce_20 = happySpecReduce_1 5# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn22 - (PComm happy_var_1 - )} - -happyReduce_21 = happySpecReduce_3 6# happyReduction_21 -happyReduction_21 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut32 happy_x_2 of { happy_var_2 -> - case happyOut26 happy_x_3 of { happy_var_3 -> - happyIn23 - (Comm happy_var_1 (reverse happy_var_2) happy_var_3 - )}}} - -happyReduce_22 = happySpecReduce_2 6# happyReduction_22 -happyReduction_22 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn23 - (CNoarg happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_23 = happySpecReduce_2 7# happyReduction_23 -happyReduction_23 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn24 - (OOpt happy_var_2 - )} - -happyReduce_24 = happyReduce 4# 7# happyReduction_24 -happyReduction_24 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut17 happy_x_2 of { happy_var_2 -> - case happyOut25 happy_x_4 of { happy_var_4 -> - happyIn24 - (OFlag happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_25 = happySpecReduce_1 8# happyReduction_25 -happyReduction_25 happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - happyIn25 - (VId happy_var_1 - )} - -happyReduce_26 = happySpecReduce_1 8# happyReduction_26 -happyReduction_26 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn25 - (VInt happy_var_1 - )} - -happyReduce_27 = happySpecReduce_1 9# happyReduction_27 -happyReduction_27 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn26 - (ATree happy_var_1 - )} - -happyReduce_28 = happySpecReduce_2 10# happyReduction_28 -happyReduction_28 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut33 happy_x_2 of { happy_var_2 -> - happyIn27 - (TApp happy_var_1 happy_var_2 - )}} - -happyReduce_29 = happySpecReduce_1 10# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn27 - (happy_var_1 - )} - -happyReduce_30 = happyReduce 4# 11# happyReduction_30 -happyReduction_30 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut34 happy_x_2 of { happy_var_2 -> - case happyOut28 happy_x_4 of { happy_var_4 -> - happyIn28 - (TAbs happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_31 = happySpecReduce_1 11# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - happyIn28 - (happy_var_1 - )} - -happyReduce_32 = happySpecReduce_1 12# happyReduction_32 -happyReduction_32 happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - happyIn29 - (TId happy_var_1 - )} - -happyReduce_33 = happySpecReduce_1 12# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn29 - (TInt happy_var_1 - )} - -happyReduce_34 = happySpecReduce_1 12# happyReduction_34 -happyReduction_34 happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - happyIn29 - (TStr happy_var_1 - )} - -happyReduce_35 = happySpecReduce_1 12# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn29 - (TFloat happy_var_1 - )} - -happyReduce_36 = happySpecReduce_3 12# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> - happyIn29 - (happy_var_2 - )} - -happyReduce_37 = happySpecReduce_1 13# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn30 - ((:[]) happy_var_1 - )} - -happyReduce_38 = happySpecReduce_3 13# happyReduction_38 -happyReduction_38 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_39 = happySpecReduce_1 14# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn31 - ((:[]) happy_var_1 - )} - -happyReduce_40 = happySpecReduce_3 14# happyReduction_40 -happyReduction_40 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn31 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_41 = happySpecReduce_0 15# happyReduction_41 -happyReduction_41 = happyIn32 - ([] - ) - -happyReduce_42 = happySpecReduce_2 15# happyReduction_42 -happyReduction_42 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { happy_var_2 -> - happyIn32 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_43 = happySpecReduce_1 16# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn33 - ((:[]) happy_var_1 - )} - -happyReduce_44 = happySpecReduce_2 16# happyReduction_44 -happyReduction_44 happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - case happyOut33 happy_x_2 of { happy_var_2 -> - happyIn33 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_45 = happySpecReduce_2 17# happyReduction_45 -happyReduction_45 happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - happyIn34 - ((:[]) happy_var_1 - )} - -happyReduce_46 = happySpecReduce_3 17# happyReduction_46 -happyReduction_46 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_3 of { happy_var_3 -> - happyIn34 - ((:) happy_var_1 happy_var_3 - )}} - -happyNewToken action sts stk [] = - happyDoAction 15# 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 _ (TV happy_dollar_dollar) -> cont 10#; - PT _ (TI happy_dollar_dollar) -> cont 11#; - PT _ (TL happy_dollar_dollar) -> cont 12#; - PT _ (TD happy_dollar_dollar) -> cont 13#; - _ -> cont 14#; - _ -> 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 - -pCommandLine tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut21 x)) - -pPipe tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut22 x)) - -pCommand tks = happySomeParser where - happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut23 x)) - -pOption tks = happySomeParser where - happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut24 x)) - -pValue tks = happySomeParser where - happySomeParser = happyThen (happyParse 4# tks) (\x -> happyReturn (happyOut25 x)) - -pArgument tks = happySomeParser where - happySomeParser = happyThen (happyParse 5# tks) (\x -> happyReturn (happyOut26 x)) - -pTree1 tks = happySomeParser where - happySomeParser = happyThen (happyParse 6# tks) (\x -> happyReturn (happyOut27 x)) - -pTree tks = happySomeParser where - happySomeParser = happyThen (happyParse 7# tks) (\x -> happyReturn (happyOut28 x)) - -pTree2 tks = happySomeParser where - happySomeParser = happyThen (happyParse 8# tks) (\x -> happyReturn (happyOut29 x)) - -pListPipe tks = happySomeParser where - happySomeParser = happyThen (happyParse 9# tks) (\x -> happyReturn (happyOut30 x)) - -pListCommand tks = happySomeParser where - happySomeParser = happyThen (happyParse 10# tks) (\x -> happyReturn (happyOut31 x)) - -pListOption tks = happySomeParser where - happySomeParser = happyThen (happyParse 11# tks) (\x -> happyReturn (happyOut32 x)) - -pListTree2 tks = happySomeParser where - happySomeParser = happyThen (happyParse 12# tks) (\x -> happyReturn (happyOut33 x)) - -pListIdent tks = happySomeParser where - happySomeParser = happyThen (happyParse 13# tks) (\x -> happyReturn (happyOut34 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/GF/Command/PrintGFShell.hs b/src/GF/Command/PrintGFShell.hs deleted file mode 100644 index 31a4584b6..000000000 --- a/src/GF/Command/PrintGFShell.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Command.PrintGFShell where - --- pretty-printer generated by the BNF converter - -import GF.Command.AbsGFShell -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 , doc (showString ",")]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - - -instance Print CommandLine where - prt i e = case e of - CLine pipes -> prPrec i 0 (concatD [prt 0 pipes]) - CEmpty -> prPrec i 0 (concatD []) - - -instance Print Pipe where - prt i e = case e of - PComm commands -> prPrec i 0 (concatD [prt 0 commands]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Command where - prt i e = case e of - Comm id options argument -> prPrec i 0 (concatD [prt 0 id , prt 0 options , prt 0 argument]) - CNoarg id options -> prPrec i 0 (concatD [prt 0 id , prt 0 options]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print Option where - prt i e = case e of - OOpt id -> prPrec i 0 (concatD [doc (showString "-") , prt 0 id]) - OFlag id value -> prPrec i 0 (concatD [doc (showString "-") , prt 0 id , doc (showString "=") , prt 0 value]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Value where - prt i e = case e of - VId id -> prPrec i 0 (concatD [prt 0 id]) - VInt n -> prPrec i 0 (concatD [prt 0 n]) - - -instance Print Argument where - prt i e = case e of - ATree tree -> prPrec i 0 (concatD [prt 0 tree]) - - -instance Print Tree where - prt i e = case e of - TApp id trees -> prPrec i 1 (concatD [prt 0 id , prt 2 trees]) - TAbs ids tree -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 ids , doc (showString "->") , prt 0 tree]) - TId id -> prPrec i 2 (concatD [prt 0 id]) - TInt n -> prPrec i 2 (concatD [prt 0 n]) - TStr str -> prPrec i 2 (concatD [prt 0 str]) - TFloat d -> prPrec i 2 (concatD [prt 0 d]) - - prtList es = case es of - [x] -> (concatD [prt 2 x]) - x:xs -> (concatD [prt 2 x , prt 2 xs]) - - diff --git a/src/GF/Compile/API.hs b/src/GF/Compile/API.hs deleted file mode 100644 index 242a9e87a..000000000 --- a/src/GF/Compile/API.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Compile.API (batchCompile, compileToGFCC) where - -import GF.Devel.Compile -import GF.Devel.GrammarToGFCC -import GF.GFCC.OptimizeGFCC -import GF.GFCC.CheckGFCC -import GF.GFCC.DataGFCC -import GF.Infra.Option -import GF.Devel.UseIO - --- | Compiles a number of source files and builds a 'GFCC' structure for them. -compileToGFCC :: Options -> [FilePath] -> IOE GFCC -compileToGFCC opts fs = - do gr <- batchCompile opts fs - let name = justModuleName (last fs) - gc1 <- putPointE opts "linking ... " $ - let (abs,gc0) = mkCanon2gfcc opts name gr - in ioeIO $ checkGFCCio gc0 - let opt = if oElem (iOpt "noopt") opts then id else optGFCC - par = if oElem (iOpt "noparse") opts then id else addParsers - return (par (opt gc1)) diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs deleted file mode 100644 index 8356f2ba2..000000000 --- a/src/GF/Compile/BackOpt.hs +++ /dev/null @@ -1,141 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : BackOpt --- 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.Compile.BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import qualified GF.Grammar.Macros 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 :: OptSpec -> Bool -doOptFactor opt = elem 2 opt - -doOptValues :: OptSpec -> Bool -doOptValues opt = elem 3 opt - -shareOpt :: OptSpec -shareOpt = [] - -paramOpt :: OptSpec -paramOpt = [2] - -valOpt :: OptSpec -valOpt = [3] - -allOpt :: OptSpec -allOpt = [2,3] - -shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -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 (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m) -shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m) -shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t))) -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 (only true in GFC) --- - -share :: Term -> Term -share t = case t of - T ty@(TComp _) cs -> shareT ty [(p, share v) | (p, v) <- cs] - _ -> C.composSafeOp share t - - 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 :: TInfo -> [[(Patt,Term)]] -> Term - finalize ty css = TSh ty [(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 (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... in GFC would be safe - -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] - _ -> C.composSafeOp values t diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs deleted file mode 100644 index b33d11017..000000000 --- a/src/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/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs deleted file mode 100644 index 422df0fd5..000000000 --- a/src/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/GF/Compile/Evaluate.hs b/src/GF/Compile/Evaluate.hs deleted file mode 100644 index a574fef40..000000000 --- a/src/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/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs deleted file mode 100644 index ae87b3e71..000000000 --- a/src/GF/Compile/Extend.hs +++ /dev/null @@ -1,136 +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 --- --- The top-level function 'extendModule' --- extends a module symbol table by indirections to the module it extends ------------------------------------------------------------------------------ - -module GF.Compile.Extend (extendModule, extendMod - ) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.PrGrammar -import GF.Infra.Modules -import GF.Compile.Update -import GF.Grammar.Macros -import GF.Data.Operations - -import Control.Monad - -extendModule :: [SourceModule] -> SourceModule -> Err SourceModule -extendModule ms (name,mod) = case mod 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 - ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod) - - ModMod m -> do - mod' <- foldM extOne m (extend m) - return (name,ModMod mod') - where - extOne mod@(Module mt st fs es ops js) (n,cond) = do - (m0,isCompl) <- do - m <- lookupModMod (MGrammar ms) n - - -- test that the module types match, and find out if the old is complete - testErr (sameMType (mtype m) mt) - ("illegal extension type to module" +++ prt name) - return (m, isCompleteModule m) ----- return (m, if (isCompleteModule m) then True else not (isCompleteModule mod)) - - -- build extension in a way depending on whether the old module is complete - js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) js - - -- if incomplete, throw away extension information - let me' = if isCompl then es else (filter ((/=n) . fst) es) - return $ Module mt st fs me' ops js1 - --- | 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 -> - BinTree Ident Info -> BinTree Ident Info -> - Err (BinTree Ident Info) -extendMod isCompl (name,cond) base old new = foldM try new $ tree2list 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 -> Info -> Info -indirInfo n info = AnyInd b n' where - (b,n') = case info of - ResValue _ -> (True,n) - ResParam _ -> (True,n) - AbsFun _ (Yes EData) -> (True,n) - AnyInd b k -> (b,k) - _ -> (False,n) ---- canonical in Abs - -perhIndir :: Ident -> Perh a -> Perh a -perhIndir n p = case p of - Yes _ -> May n - _ -> p - -extendAnyInfo :: Bool -> Ident -> Ident -> Info -> Info -> Err Info -extendAnyInfo isc n o i j = - errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of - (AbsCat mc1 mf1, AbsCat mc2 mf2) -> - liftM2 AbsCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) --- add cstrs - (AbsFun mt1 md1, AbsFun mt2 md2) -> - liftM2 AbsFun (updn isc n mt1 mt2) (updn isc n md1 md2) --- add defs - (ResParam mt1, ResParam mt2) -> - liftM ResParam $ updn isc n mt1 mt2 - (ResValue mt1, ResValue mt2) -> - liftM ResValue $ updn isc n mt1 mt2 - (ResOper mt1 m1, ResOper mt2 m2) -> ---- extendResOper n mt1 m1 mt2 m2 - liftM2 ResOper (updn isc n mt1 mt2) (updn isc n m1 m2) - (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> - liftM3 CncCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) (updn isc n mp1 mp2) - (CncFun m mt1 md1, CncFun _ mt2 md2) -> - liftM2 (CncFun m) (updn isc n mt1 mt2) (updn isc n md1 md2) - ----- (AnyInd _ _, ResOper _ _) -> return j ---- - - (AnyInd b1 m1, AnyInd b2 m2) -> do - testErr (b1 == b2) "inconsistent indirection status" ----- commented out as work-around for a spurious problem in ----- TestResourceFre; should look at building of completion. 17/11/2004 - testErr (m1 == m2) $ - "different sources of indirection: " +++ show m1 +++ show m2 - return i - - _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j - ---- where - -updn isc n = if isc then (updatePerhaps n) else (updatePerhapsHard n) -updc isc n = if True then (updatePerhaps n) else (updatePerhapsHard n) - - - -{- ---- no more needed: this is done in Rebuild --- opers declared in an interface and defined in an instance are a special case - -extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of - (Nope,_) -> return $ ResOper (strip mt1) m2 - _ -> liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2) - where - strip (Yes t) = Yes $ strp t - strip m = m - strp t = case t of - Q _ c -> Vr c - QC _ c -> Vr c - _ -> composSafeOp strp t --} diff --git a/src/GF/Compile/Flatten.hs b/src/GF/Compile/Flatten.hs deleted file mode 100644 index 6b25edebb..000000000 --- a/src/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 = mkIdent 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/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs deleted file mode 100644 index 294edbf9a..000000000 --- a/src/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/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs deleted file mode 100644 index 09c0d3d95..000000000 --- a/src/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/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs deleted file mode 100644 index d016a7e47..000000000 --- a/src/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/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs deleted file mode 100644 index 10831b5c6..000000000 --- a/src/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/GF/Compile/MkUnion.hs b/src/GF/Compile/MkUnion.hs deleted file mode 100644 index b4b1f40c8..000000000 --- a/src/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/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs deleted file mode 100644 index 8331057d1..000000000 --- a/src/GF/Compile/ModDeps.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ModDeps --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Check correctness of module dependencies. Incomplete. --- --- AR 13\/5\/2003 ------------------------------------------------------------------------------ - -module GF.Compile.ModDeps (mkSourceGrammar, - moduleDeps, - openInterfaces, - requiredCanModules - ) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Grammar.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules - -import GF.Data.Operations - -import Control.Monad -import Data.List - --- | to check uniqueness of module names and import names, the --- appropriateness of import and extend types, --- to build a dependency graph of modules, and to sort them topologically -mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar -mkSourceGrammar ms = do - let ns = map fst ms - checkUniqueErr ns - mapM (checkUniqueImportNames ns . snd) ms - deps <- moduleDeps ms - deplist <- either - return - (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ - topoTest deps - return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist] - -checkUniqueErr :: (Show i, Eq i) => [i] -> Err () -checkUniqueErr ms = do - let msg = checkUnique ms - if null msg then return () else Bad $ unlines msg - --- | check that import names don't clash with module names -checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () -checkUniqueImportNames ns mo = case mo of - ModMod m -> test [n | OQualif _ n v <- opens m, n /= v] - _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo - where - - test ms = testErr (all (`notElem` ns) ms) - ("import names clashing with module names among" +++ - unwords (map prt ms)) - -type Dependencies = [(IdentM Ident,[IdentM Ident])] - --- | to decide what modules immediately depend on what, and check if the --- dependencies are appropriate -moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies -moduleDeps ms = mapM deps ms where - deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of - ModMod m -> case mtype m of - MTConcrete a -> do - aty <- lookupModuleType gr a - testErr (aty == MTAbstract) "the of-module is not an abstract syntax" - chDep (IdentM c (MTConcrete a)) - (extends m) (MTConcrete a) (opens m) MTResource - t -> chDep (IdentM c t) (extends m) t (opens m) t - - chDep it es ety os oty = do - ests <- mapM (lookupModuleType gr) es - testErr (all (compatMType ety) ests) "inappropriate extension module type" ----- osts <- mapM (lookupModuleType gr . openedModule) os ----- testErr (all (compatOType oty) osts) "inappropriate open module type" - let ab = case it of - IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] - _ -> [] ---- - return (it, ab ++ - [IdentM e ety | e <- es] ++ - [IdentM (openedModule o) oty | o <- os]) - - -- check for superficial compatibility, not submodule relation etc: what can be extended - compatMType mt0 mt = case (mt0,mt) of - (MTResource, MTConcrete _) -> True - (MTInstance _, MTConcrete _) -> True - (MTInterface, MTAbstract) -> True - (MTConcrete _, MTConcrete _) -> True - (MTInstance _, MTInstance _) -> True - (MTReuse _, MTReuse _) -> True - (MTInstance _, MTResource) -> True - (MTResource, MTInstance _) -> True - ---- some more? - _ -> mt0 == mt - -- in the same way; this defines what can be opened - compatOType mt0 mt = case mt0 of - MTAbstract -> mt == MTAbstract - MTTransfer _ _ -> mt == MTAbstract - _ -> case mt of - MTResource -> True - MTReuse _ -> True - MTInterface -> True - MTInstance _ -> True - _ -> False - - gr = MGrammar ms --- hack - -openInterfaces :: Dependencies -> Ident -> Err [Ident] -openInterfaces ds m = do - let deps = [(i,ds) | (IdentM i _,ds) <- ds] - let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is] - let mods = iterFix (concatMap more) (more (m,undefined)) - return $ [i | (i,MTInterface) <- mods] - --- | this function finds out what modules are really needed in the canonical gr. --- its argument is typically a concrete module name -requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i] -requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where - exts = allExtends gr c - ops = if isSingle - then map fst (modules gr) - else iterFix (concatMap more) $ exts - more i = errVal [] $ do - m <- lookupModMod gr i - return $ extends m ++ [o | o <- map openedModule (opens m)] - notReuse i = errVal True $ do - m <- lookupModMod gr i - return $ isModRes m -- to exclude reused Cnc and Abs from required - - -{- --- to test -exampleDeps = [ - (ir "Nat",[ii "Gen", ir "Adj"]), - (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]), - (ir "Nou",[ii "Cas"]) - ] - -ii s = IdentM (IC s) MTInterface -ir s = IdentM (IC s) MTResource --} - diff --git a/src/GF/Compile/NewRename.hs b/src/GF/Compile/NewRename.hs deleted file mode 100644 index cec8ed24f..000000000 --- a/src/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/GF/Compile/NoParse.hs b/src/GF/Compile/NoParse.hs deleted file mode 100644 index c8f828970..000000000 --- a/src/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/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs deleted file mode 100644 index a540ee715..000000000 --- a/src/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 ([(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/GF/Compile/PGrammar.hs b/src/GF/Compile/PGrammar.hs deleted file mode 100644 index 521f616b5..000000000 --- a/src/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/GF/Compile/PrOld.hs b/src/GF/Compile/PrOld.hs deleted file mode 100644 index 29920fab6..000000000 --- a/src/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/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs deleted file mode 100644 index 152983b96..000000000 --- a/src/GF/Compile/Rebuild.hs +++ /dev/null @@ -1,99 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Rebuild --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 21:08:14 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Rebuild a source module from incomplete and its with-instance. ------------------------------------------------------------------------------ - -module GF.Compile.Rebuild (rebuildModule) where - -import GF.Grammar.Grammar -import GF.Compile.ModDeps -import GF.Grammar.PrGrammar -import GF.Grammar.Lookup -import GF.Compile.Extend -import GF.Grammar.Macros - -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Data.Operations - -import Data.List (nub) - --- | rebuilding instance + interface, and "with" modules, prior to renaming. --- AR 24/10/2003 -rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule -rebuildModule ms mo@(i,mi) = do - let gr = MGrammar ms ----- deps <- moduleDeps ms ----- is <- openInterfaces deps i - let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 - mi' <- case mi of - - -- add the information given in interface into an instance module - ModMod m -> do - testErr (null is || mstatus m == MSIncomplete) - ("module" +++ prt i +++ - "has open interfaces and must therefore be declared incomplete") - case mtype m of - MTInstance i0 -> do - m1 <- lookupModMod gr i0 - testErr (isModRes m1) ("interface expected instead of" +++ prt i0) - m' <- do - js' <- extendMod False (i0,const True) i (jments m1) (jments m) - --- to avoid double inclusions, in instance I of I0 = J0 ** ... - case extends m of - [] -> return $ replaceJudgements m js' - j0s -> do - m0s <- mapM (lookupModMod gr) j0s - let notInM0 c _ = all (not . isInBinTree c . jments) m0s - let js2 = filterBinTree notInM0 js' - return $ replaceJudgements m js2 - return $ ModMod m' - _ -> return mi - - -- add the instance opens to an incomplete module "with" instances - -- ModWith mt stat ext me ops -> do - ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do - let insts = [(inf,inst) | OQualif _ inf inst <- ops] - let infs = map fst insts - let stat' = ifNull MSComplete (const MSIncomplete) - [i | i <- is, notElem i infs] - testErr (stat' == MSComplete || stat == MSIncomplete) - ("module" +++ prt i +++ "remains incomplete") - Module mt0 _ fs me' ops0 js <- lookupModMod gr ext - let ops1 = nub $ - ops_ ++ -- N.B. js has been name-resolved already - ops ++ [o | o <- ops0, notElem (openedModule o) infs] - ++ [oQualif i i | i <- map snd insts] ---- - ++ [oSimple i | i <- map snd insts] ---- - - --- check if me is incomplete - let fs1 = fs_ ++ fs -- new flags have priority - let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] - let js1 = buildTree (tree2list js_ ++ js0) - return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 - ---- (mapTree (qualifInstanceInfo insts) js) -- not needed - - _ -> return mi - return (i,mi') - -checkCompleteInstance :: SourceRes -> SourceRes -> Err () -checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $ - checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc' - where - abs' = tree2list $ jments abs - cnc' = jments cnc - checkComplete sought given = foldr ckOne [] sought - where - ckOne f = if isInBinTree f given - then id - else (("Error: no definition given to" +++ prt f):) - diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs deleted file mode 100644 index 28aae9b84..000000000 --- a/src/GF/Compile/RemoveLiT.hs +++ /dev/null @@ -1,63 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : RemoveLiT --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:21:45 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003 --- --- What the program does is replace the occurrences of Lin C with the actual --- definition T given in lincat C = T ; with {s : Str} if no lincat is found. --- The procedure is uncertain, if T contains another Lin. ------------------------------------------------------------------------------ - -module GF.Compile.RemoveLiT (removeLiT) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.Lookup - -import GF.Data.Operations - -import Control.Monad - -removeLiT :: SourceGrammar -> Err SourceGrammar -removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr) - -remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo) -remlModule gr mi@(name,mod) = case mod of - ModMod (Module mt st fs me ops js) -> do - js1 <- mapMTree (remlResInfo gr) js - let mod2 = ModMod $ Module mt st fs me ops js1 - return $ (name,mod2) - _ -> return mi - -remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info) -remlResInfo gr mi@(i,info) = case info of - ResOper pty ptr -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr) - CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr) - CncFun mt ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt) (ren ptr) (ren ppr) - _ -> return mi - where - ren = remlPerh gr - -remlPerh gr pt = case pt of - Yes t -> liftM Yes $ remlTerm gr t - _ -> return pt - -remlTerm :: SourceGrammar -> Term -> Err Term -remlTerm gr trm = case trm of - LiT c -> look c >>= remlTerm gr - _ -> composOp (remlTerm gr) trm - where - look c = err (const $ return defLinType) return $ lookupLincat gr m c - m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of - cnc:_ -> cnc -- actually there is always exactly one - _ -> zIdent "CNC" diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs deleted file mode 100644 index c3fef557b..000000000 --- a/src/GF/Compile/Rename.hs +++ /dev/null @@ -1,338 +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 --- --- Dependency analysis between modules has been performed before this pass. --- Hence we can proceed by @fold@ing "from left to right". ------------------------------------------------------------------------------ - -module GF.Compile.Rename (renameGrammar, - 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 -import Data.List (nub) -import Debug.Trace (trace) - -renameGrammar :: SourceGrammar -> Err SourceGrammar -renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g) - --- | 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 :: [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 - status <- buildStatus (MGrammar 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 = (StatusTree, [(OpenSpec Ident, StatusTree)]) - -type StatusTree = BinTree Ident StatusInfo - -type StatusInfo = Ident -> Term - -renameIdentTerm :: Status -> Term -> Err Term -renameIdentTerm env@(act,imps) t = - errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $ - case t of - Vr c -> ident predefAbs c - Cn c -> ident (\_ s -> Bad s) c - Q m' c | m' == cPredef {- && isInPredefined c -} -> return t - Q m' c -> do - m <- lookupErr m' qualifs - f <- lookupTree prt c m - return $ f c - QC m' c | m' == cPredef {- && isInPredefined c -} -> return t - QC m' c -> do - m <- lookupErr m' qualifs - f <- lookupTree prt c m - return $ f c - _ -> return t - where - opens = [st | (OSimple _ _,st) <- imps] - qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++ - [(m, st) | (OSimple _ m, st) <- 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 "Float" -> return $ Q cPredefAbs cFloat - IC "String" -> return $ Q cPredefAbs cString - _ -> Bad s - - ident alt c = case lookupTree prt c act of - Ok f -> return $ f c - _ -> case lookupTreeManyAll prt opens c of - [f] -> return $ f c - [] -> alt c ("constant not found:" +++ prt c) - fs -> case nub [f c | f <- fs] of - [tr] -> return tr - ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t) ----- ts -> return $ Strs $ (cnIC "#conflict") : reverse ts - -- a warning will be generated in CheckGrammar, and the head returned - -- in next V: - -- Bad $ "conflicting imports:" +++ unwords (map prt ts) - - ---- | 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' - -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 <- allExtends gr1 c] ++ allOpens m - mods <- mapM (lookupModule gr1 . openedModule) ops - let sts = map modInfo2status $ zip ops mods - return $ if isModCnc m - then (emptyBinTree, 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) - ResOverload tysts -> liftM ResOverload $ mapM (pairM rent) tysts - - ResParam (Yes (pp,m)) -> do - pp' <- mapM (renameParam status) pp - return $ ResParam $ Yes (pp',m) - ResValue (Yes (t,m)) -> do - t' <- rent t - return $ ResValue $ Yes (t',m) - 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 - _ -> 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 :: Status -> 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' <- renameIdentTerm env $ Cn c - case c' of - QC p d -> renp $ PP p d ps --- Q p d -> renp $ PP p d ps --- why this? AR 15/3/2008 - _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) - - PP p c ps -> do - - (p', c') <- case renameIdentTerm env (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) - - PM p c -> do - (p', c') <- case renameIdentTerm env (Q p c) of - Ok (Q p' c') -> return (p',c') - _ -> prtBad "not a pattern macro" patt - return (PM p' c', []) - - 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 :: 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/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs deleted file mode 100644 index 0e24da601..000000000 --- a/src/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/GF/Compile/Update.hs b/src/GF/Compile/Update.hs deleted file mode 100644 index 82d7a609e..000000000 --- a/src/GF/Compile/Update.hs +++ /dev/null @@ -1,135 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Update --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 18:39:44 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo, - -- * these auxiliaries should be somewhere else - -- since they don't use the info types - groupInfos, sortInfos, combineInfos, unifyInfos, - tryInsert, unifAbsDefs, unifConstrs - ) where - -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.PrGrammar -import GF.Infra.Modules - -import GF.Data.Operations - -import Data.List -import Control.Monad - --- | update a resource module by adding a new or changing an old definition -updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar -updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where - upd (n,mod) - | n /= m = (n,mod) - | n == m = case mod of - ModMod r -> (m,ModMod $ updateModule r i info) - _ -> (n,mod) --- no error msg - --- | combine a list of definitions into a balanced binary search tree -buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info) -buildAnyTree ias = do - ias' <- combineAnyInfos ias - return $ buildTree ias' - - --- | unifying information for abstract, resource, and concrete -combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)] -combineAnyInfos = combineInfos unifyAnyInfo - -unifyAnyInfo :: Ident -> Info -> Info -> Err Info -unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of - (AbsCat mc1 mf1, AbsCat mc2 mf2) -> - liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs - (AbsFun mt1 md1, AbsFun mt2 md2) -> - liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs - - (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2 - (ResOper mt1 m1, ResOper mt2 m2) -> - liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2) - - (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> - liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2) - (CncFun m mt1 md1, CncFun _ mt2 md2) -> - liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs --- for bw compatibility with unspecified printnames in old GF - (CncFun Nothing Nope (Yes pr),_) -> - unifyAnyInfo c (CncCat Nope Nope (Yes pr)) j - (_,CncFun Nothing Nope (Yes pr)) -> - unifyAnyInfo c i (CncCat Nope Nope (Yes pr)) - - _ -> Bad $ "cannot unify informations in" ++++ show i ++++ "and" ++++ show j - ---- these auxiliaries should be somewhere else since they don't use the info types - -groupInfos :: Eq a => [(a,b)] -> [[(a,b)]] -groupInfos = groupBy (\i j -> fst i == fst j) - -sortInfos :: Ord a => [(a,b)] -> [(a,b)] -sortInfos = sortBy (\i j -> compare (fst i) (fst j)) - -combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)] -combineInfos f ris = do - let riss = groupInfos $ sortInfos ris - mapM (unifyInfos f) riss - -unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b) -unifyInfos _ [] = Bad "empty info list" -unifyInfos unif ris = do - let c = fst $ head ris - let infos = map snd ris - let ([i],is) = splitAt 1 infos - info <- foldM (unif c) i is - return (c,info) - - -tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> - BinTree a b -> (a,b) -> Err (BinTree a b) -tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of - Ok info0 -> do - info1 <- unif info info0 - return $ updateTree (x,info1) tree - _ -> return $ updateTree (x,indir info) tree - -{- ---- -case tree of - NT -> return $ BT (x, indir info) NT NT - BT c@(a,info0) left right - | x < a -> do - left' <- tryInsert unif indir left z - return $ BT c left' right - | x > a -> do - right' <- tryInsert unif indir right z - return $ BT c left right' - | x == a -> do - info' <- unif info info0 - return $ BT (x,info') left right --} - ---- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m - -unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term) -unifAbsDefs p1 p2 = case (p1,p2) of - (Nope, _) -> return p2 - (_, Nope) -> return p1 - (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order! - _ -> Bad "update conflict for definitions" - -unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term]) -unifConstrs p1 p2 = case (p1,p2) of - (Nope, _) -> return p2 - (_, Nope) -> return p1 - (Yes bs, Yes ds) -> return $ yes $ bs ++ ds - _ -> Bad "update conflict for constructors" diff --git a/src/GF/Compile/Wordlist.hs b/src/GF/Compile/Wordlist.hs deleted file mode 100644 index 3fbc066bd..000000000 --- a/src/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/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs deleted file mode 100644 index 354bdea65..000000000 --- a/src/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/GF/Conversion/GFCtoSimple.hs b/src/GF/Conversion/GFCtoSimple.hs deleted file mode 100644 index b6a34a8ce..000000000 --- a/src/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/GF/Conversion/Haskell.hs b/src/GF/Conversion/Haskell.hs deleted file mode 100644 index abe651e1e..000000000 --- a/src/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/GF/Conversion/MCFGtoCFG.hs b/src/GF/Conversion/MCFGtoCFG.hs deleted file mode 100644 index a58c31d37..000000000 --- a/src/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/GF/Conversion/MCFGtoFCFG.hs b/src/GF/Conversion/MCFGtoFCFG.hs deleted file mode 100644 index 70aa4644d..000000000 --- a/src/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/GF/Conversion/Prolog.hs b/src/GF/Conversion/Prolog.hs deleted file mode 100644 index b930cb476..000000000 --- a/src/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/GF/Conversion/RemoveEpsilon.hs b/src/GF/Conversion/RemoveEpsilon.hs deleted file mode 100644 index 0e5dafb38..000000000 --- a/src/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/GF/Conversion/RemoveErasing.hs b/src/GF/Conversion/RemoveErasing.hs deleted file mode 100644 index 1dc2560fc..000000000 --- a/src/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/GF/Conversion/RemoveSingletons.hs b/src/GF/Conversion/RemoveSingletons.hs deleted file mode 100644 index 4b9992a4d..000000000 --- a/src/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/GF/Conversion/SimpleToFCFG.hs b/src/GF/Conversion/SimpleToFCFG.hs deleted file mode 100644 index 4ff5781f9..000000000 --- a/src/GF/Conversion/SimpleToFCFG.hs +++ /dev/null @@ -1,536 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Converting SimpleGFC grammars to fast nonerasing MCFG grammar. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. ------------------------------------------------------------------------------ - - -module GF.Conversion.SimpleToFCFG - (convertConcrete) where - -import GF.Infra.PrintClass - -import Control.Monad - -import GF.Formalism.Utilities -import GF.Formalism.FCFG - -import GF.GFCC.Macros --hiding (prt) -import GF.GFCC.DataGFCC -import GF.GFCC.CId - -import GF.Data.BacktrackM -import GF.Data.SortedList -import GF.Data.Utilities (updateNthM, sortNub) - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.List as List -import Data.Array -import Data.Maybe - ----------------------------------------------------------------------- --- main conversion function - -convertConcrete :: Abstr -> Concr -> FGrammar -convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats' - where abs_defs = Map.assocs (funs abs) - conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient" - cats = lincats cnc - (abs_defs',conc',cats') = expandHOAS abs_defs conc cats - -expandHOAS :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> ([(CId,(Type,Exp))],TermMap,TermMap) -expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, - Map.unions [lins, hoLins, varLins], - Map.unions [lincats, hoLincats, varLincat]) - where - -- replace higher-order fun argument types with new categories - funs' = [(f,(fixType ty,e)) | (f,(ty,e)) <- funs] - where - fixType :: Type -> Type - fixType ty = let (ats,rt) = typeSkeleton ty in cftype (map catName ats) rt - - hoTypes :: [(Int,CId)] - hoTypes = sortNub [(n,c) | (_,(ty,_)) <- funs, (n,c) <- fst (typeSkeleton ty), n > 0] - hoCats = sortNub (map snd hoTypes) - -- for each Cat with N bindings, we add a new category _NCat - -- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat - hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),EEq [])) | ty@(n,c) <- hoTypes] - -- lincats for the new categories - hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes] - -- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ... - hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes] - where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c) - -- for each Cat, we a add a fun _Var_Cat : _Var -> Cat - varFuns = [(varFunName cat, (cftype [varCat] cat,EEq [])) | cat <- hoCats] - -- linearizations of the _Var_Cat functions - varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats] - -- lincat for the _Var category - varLincat = Map.singleton varCat (R [S []]) - - lincatOf c = fromMaybe (error $ "No lincat for " ++ prt c) $ Map.lookup c lincats - - modifyRec :: ([Term] -> [Term]) -> Term -> Term - modifyRec f (R xs) = R (f xs) - modifyRec _ t = error $ "Not a record: " ++ show t - - varCat = CId "_Var" - - catName :: (Int,CId) -> CId - catName (0,c) = c - catName (n,CId c) = CId ("_" ++ show n ++ c) - - funName :: (Int,CId) -> CId - funName (n,CId c) = CId ("__" ++ show n ++ c) - - varFunName :: CId -> CId - varFunName (CId c) = CId ("_Var_" ++ c) - --- replaces __NCat with _B and _Var_Cat with _. --- the temporary names are just there to avoid name collisions. -fixHoasFuns :: FGrammar -> FGrammar -fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs) - where fixName (Name (CId ('_':'_':_)) p) = Name (CId "_B") p - fixName (Name (CId n) p) | "_Var_" `List.isPrefixOf` n = Name wildCId p - fixName n = n - -convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar -convert abs_defs cnc_defs cat_defs = getFGrammar (loop frulesEnv) - where - srules = [ - (XRule id args res (map findLinType args) (findLinType res) term) | - (id, (ty,_)) <- abs_defs, let (args,res) = catSkeleton ty, - term <- Map.lookup id cnc_defs] - - findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) - - (xrulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules - where - helper (xrulesMap,frulesEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) = - let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap - frulesEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env) - frulesEnv - (mkSingletonSelectors cnc_defs cnc_res) - in xrulesMap' `seq` frulesEnv' `seq` (xrulesMap',frulesEnv') - - loop frulesEnv = - let (todo, frulesEnv') = takeToDoRules xrulesMap frulesEnv - in case todo of - [] -> frulesEnv' - _ -> loop $! List.foldl' (\env (srules,selector) -> - List.foldl' (\env srule -> convertRule cnc_defs selector srule env) env srules) frulesEnv' todo - -convertRule :: TermMap -> TermSelector -> XRule -> FRulesEnv -> FRulesEnv -convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv = - foldBM addRule - frulesEnv - (convertTerm cnc_defs selector term [([],[])]) - (protoFCat cat, map (\scat -> (protoFCat scat,[])) args, ctype, ctypes) - where - addRule linRec (newCat', newArgs', _, _) env0 = - let (env1, newCat) = genFCatHead env0 newCat' - (env2, newArgs,idxArgs) = foldr (\((xcat@(PFCat cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) -> - let xargs = xcat:[PFCat cat [path] tcs | path <- reverse xpaths] - (env1, xargs1) = List.mapAccumL (genFCatArg cnc_defs ctype) env xargs - in case xcat of - PFCat _ [] _ -> (env , args, all_args) - _ -> (env1,xargs1++args,(idx,zip xargs1 xargs):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..]) - - newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- case newCat' of {PFCat _ rcs _ -> rcs}] - - (_,newProfile) = List.mapAccumL accumProf 0 newArgs' - where - accumProf nr (PFCat _ [] _,_ ) = (nr, Unify [] ) - accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt]) - where cnt = length xpaths - - rule = FRule (Name fun newProfile) newArgs newCat newLinRec - in addFRule env2 rule - -translateLin idxArgs lbl' [] = array (0,-1) [] -translateLin idxArgs lbl' ((lbl,syms) : lins) - | lbl' == lbl = listArray (0,length syms-1) (map instSym syms) - | otherwise = translateLin idxArgs lbl' lins - where - instSym = symbol (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok - instCat lbl nr xnr nr' ((idx,xargs):idxArgs) - | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr - in FSymCat fcat (index lbl rcs 0) (nr'+xnr) - | otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs - - index lbl' (lbl:lbls) idx - | lbl' == lbl = idx - | otherwise = index lbl' lbls $! (idx+1) - - ----------------------------------------------------------------------- --- term conversion - -type CnvMonad a = BacktrackM Env a - -type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term]) -type LinRec = [(FPath, [Symbol (FPath, FIndex, Int) FToken])] - -type TermMap = Map.Map CId Term - -convertTerm :: TermMap -> TermSelector -> Term -> LinRec -> CnvMonad LinRec -convertTerm cnc_defs selector (V nr) ((lbl_path,lin) : lins) = convertArg selector nr [] lbl_path lin lins -convertTerm cnc_defs selector (C nr) ((lbl_path,lin) : lins) = convertCon selector nr lbl_path lin lins -convertTerm cnc_defs selector (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins - -convertTerm cnc_defs selector (P term sel) lins = do nr <- evalTerm cnc_defs [] sel - convertTerm cnc_defs (TuplePrj nr selector) term lins -convertTerm cnc_defs selector (FV vars) lins = do term <- member vars - convertTerm cnc_defs selector term lins -convertTerm cnc_defs selector (S ts) ((lbl_path,lin) : lins) = do projectHead lbl_path - foldM (\lins t -> convertTerm cnc_defs selector t lins) ((lbl_path,lin) : lins) (reverse ts) -convertTerm cnc_defs selector (K (KS str)) ((lbl_path,lin) : lins) = - do projectHead lbl_path - return ((lbl_path,Tok str : lin) : lins) -convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = - do projectHead lbl_path - toks <- member (strs:[strs' | Var strs' _ <- vars]) - return ((lbl_path, map Tok toks ++ lin) : lins) -convertTerm cnc_defs selector (RP _ term) lins = convertTerm cnc_defs selector term lins -convertTerm cnc_defs selector (F id) lins = do term <- Map.lookup id cnc_defs - convertTerm cnc_defs selector term lins -convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do - ss <- case t of - R ss -> return ss - F f -> do - t <- Map.lookup f cnc_defs - case t of - R ss -> return ss - convertRec cnc_defs selector 0 [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins -convertTerm cnc_defs selector x lins = error ("convertTerm ("++show x++")") - - -convertArg (TupleSel record) nr path lbl_path lin lins = - foldM (\lins (lbl, selector) -> convertArg selector nr (lbl:path) (lbl:lbl_path) lin lins) lins record -convertArg (TuplePrj lbl selector) nr path lbl_path lin lins = - convertArg selector nr (lbl:path) lbl_path lin lins -convertArg (ConSel indices) nr path lbl_path lin lins = do - index <- member indices - restrictHead lbl_path index - restrictArg nr path index - return lins -convertArg StrSel nr path lbl_path lin lins = do - projectHead lbl_path - xnr <- projectArg nr path - return ((lbl_path, GF.Formalism.Utilities.Cat (path, nr, xnr) : lin) : lins) - -convertCon (ConSel indices) index lbl_path lin lins = do - guard (index `elem` indices) - restrictHead lbl_path index - return lins -convertCon x _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x - -convertRec cnc_defs selector index [] lbl_path lin lins = return lins -convertRec cnc_defs selector@(TupleSel fields) index (val:record) lbl_path lin lins = select fields - where - select [] = convertRec cnc_defs selector (index+1) record lbl_path lin lins - select ((index',sub_sel) : fields) - | index == index' = do lins <- convertTerm cnc_defs sub_sel val ((index:lbl_path,lin) : lins) - convertRec cnc_defs selector (index+1) record lbl_path lin lins - | otherwise = select fields -convertRec cnc_defs (TuplePrj index' sub_sel) index record lbl_path lin lins = do - convertTerm cnc_defs sub_sel (record !! (index'-index)) ((lbl_path,lin) : lins) - - ------------------------------------------------------------- --- eval a term to ground terms - -evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex -evalTerm cnc_defs path (V nr) = do term <- readArgCType nr - unifyPType nr (reverse path) (selectTerm path term) -evalTerm cnc_defs path (C nr) = return nr -evalTerm cnc_defs path (R record) = case path of - (index:path) -> evalTerm cnc_defs path (record !! index) -evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel - evalTerm cnc_defs (index:path) term -evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path -evalTerm cnc_defs path (RP alias _) = evalTerm cnc_defs path alias -evalTerm cnc_defs path (F id) = do term <- Map.lookup id cnc_defs - evalTerm cnc_defs path term -evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") - -unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex -unifyPType nr path (C max_index) = - do (_, args, _, _) <- readState - let (PFCat _ _ tcs,_) = args !! nr - case lookup path tcs of - Just index -> return index - Nothing -> do index <- member [0..max_index] - restrictArg nr path index - return index -unifyPType nr path (RP alias _) = unifyPType nr path alias - -unifyPType nr path t = error $ "unifyPType " ++ show t ---- AR 2/10/2007 - -selectTerm :: FPath -> Term -> Term -selectTerm [] term = term -selectTerm (index:path) (R record) = selectTerm path (record !! index) -selectTerm path (RP _ term) = selectTerm path term - - ----------------------------------------------------------------------- --- FRulesEnv - -data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule] -type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat))) - -data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)] - -protoFCat :: CId -> ProtoFCat -protoFCat cat = PFCat cat [] [] - -emptyFRulesEnv = FRulesEnv 0 (ins fcatString (CId "String") [[0]] [] $ - ins fcatInt (CId "Int") [[0]] [] $ - ins fcatFloat (CId "Float") [[0]] [] $ - ins fcatVar (CId "_Var") [[0]] [] $ - Map.empty) [] - where - ins fcat cat rcs tcs fcatSet = - Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s fcatSet - where - right_fcat = Right fcat - tmap_s = Map.singleton tcs right_fcat - rmap_s = Map.singleton rcs tmap_s - -addFRule :: FRulesEnv -> FRule -> FRulesEnv -addFRule (FRulesEnv last_id fcatSet rules) rule = FRulesEnv last_id fcatSet (rule:rules) - -getFGrammar :: FRulesEnv -> FGrammar -getFGrammar (FRulesEnv last_id fcatSet rules) = (rules, Map.map getFCatList fcatSet) - where - getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs - -genFCatHead :: FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat) -genFCatHead env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs) = - case Map.lookup cat fcatSet >>= Map.lookup rcs >>= Map.lookup tcs of - Just (Left fcat) -> (FRulesEnv last_id (ins fcat) rules, fcat) - Just (Right fcat) -> (env, fcat) - Nothing -> let fcat = last_id+1 - in (FRulesEnv fcat (ins fcat) rules, fcat) - where - ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s fcatSet - where - right_fcat = Right fcat - tmap_s = Map.singleton tcs right_fcat - rmap_s = Map.singleton rcs tmap_s - -genFCatArg :: TermMap -> Term -> FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat) -genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs) = - case Map.lookup cat fcatSet >>= Map.lookup rcs of - Just tmap -> case Map.lookup tcs tmap of - Just (Left fcat) -> (env, fcat) - Just (Right fcat) -> (env, fcat) - Nothing -> ins tmap - Nothing -> ins Map.empty - where - ins tmap = - let fcat = last_id+1 - (either_fcat,last_id1,tmap1,rules1) - = foldBM (\tcs st (either_fcat,last_id,tmap,rules) -> - let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap - rule = FRule (Name (CId "_") [Unify [0]]) [fcat_arg] fcat - (listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]]) - in if st - then (Right fcat, last_id1,tmap1,rule:rules) - else (either_fcat,last_id, tmap, rules)) - (Left fcat,fcat,Map.insert tcs either_fcat tmap,rules) - (gen_tcs ctype [] []) - False - rmap1 = Map.singleton rcs tmap1 - in (FRulesEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 fcatSet) rules1, fcat) - where - addArg tcs last_id tmap = - case Map.lookup tcs tmap of - Just (Left fcat) -> (last_id, tmap, fcat) - Just (Right fcat) -> (last_id, tmap, fcat) - Nothing -> let fcat = last_id+1 - in (fcat, Map.insert tcs (Left fcat) tmap, fcat) - - gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)] - gen_tcs (R record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record) - gen_tcs (S _) path acc = return acc - gen_tcs (RP _ term) path acc = gen_tcs term path acc - gen_tcs (C max_index) path acc = - case List.lookup path tcs of - Just index -> return $! addConstraint path index acc - Nothing -> do writeState True - index <- member [0..max_index] - return $! addConstraint path index acc - where - addConstraint path0 index0 (c@(path,index) : cs) - | path0 > path = c:addConstraint path0 index0 cs - addConstraint path0 index0 cs = (path0,index0) : cs - gen_tcs (F id) path acc = case Map.lookup id cnc_defs of - Just term -> gen_tcs term path acc - Nothing -> error ("unknown identifier: "++prt id) - - - ------------------------------------------------------------- --- TODO queue organization - -type XRulesMap = Map.Map CId [XRule] -data XRule = XRule CId {- function -} - [CId] {- argument types -} - CId {- result type -} - [Term] {- argument lin-types representation -} - Term {- result lin-type representation -} - Term {- body -} - -takeToDoRules :: XRulesMap -> FRulesEnv -> ([([XRule], TermSelector)], FRulesEnv) -takeToDoRules xrulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules) - where - (todo,fcatSet') = - Map.mapAccumWithKey (\todo cat rmap -> - let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap -> - let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs either_xcat -> - case either_xcat of - Left xcat -> (tcs:tcss,Right xcat) - Right xcat -> ( tcss,either_xcat)) [] tmap - in case tcss of - [] -> ( todo,tmap ) - _ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap - mb_srules = Map.lookup cat xrulesMap - Just srules = mb_srules - - in case mb_srules of - Just srules -> (todo1,rmap1) - Nothing -> (todo ,rmap1)) [] fcatSet - - ------------------------------------------------------------- --- The TermSelector - -data TermSelector - = TupleSel [(FIndex, TermSelector)] - | TuplePrj FIndex TermSelector - | ConSel [FIndex] - | StrSel - deriving Show - -mkSingletonSelectors :: TermMap - -> Term -- ^ Type representation term - -> [TermSelector] -- ^ list of selectors containing just one string field -mkSingletonSelectors cnc_defs term = sels0 - where - (sels0,tcss0) = loop [] ([],[]) term - - loop path st (R record) = List.foldl' (\st (index,term) -> loop (index:path) st term) st (zip [0..] record) - loop path st (RP _ t) = loop path st t - loop path (sels,tcss) (C i) = ( sels,map ((,) path) [0..i] : tcss) - loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss) - loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of - Just term -> loop path (sels,tcss) term - Nothing -> error ("unknown identifier: "++prt id) - -mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector -mkSelector rcs tcss = - List.foldl' addRestriction (case xs of - (path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys - where - xs = [ reverse path | path <- rcs] - ys = [(reverse path,term) | tcs <- tcss, (path,term) <- tcs] - - addRestriction :: TermSelector -> (FPath,FIndex) -> TermSelector - addRestriction (ConSel indices) ([] ,n_index) = ConSel (add indices) - where - add [] = [n_index] - add (index':indices) - | n_index == index' = index': indices - | otherwise = index':add indices - addRestriction (TupleSel fields) (index : path,n_index) = TupleSel (add fields) - where - add [] = [(index,path2selector (ConSel [n_index]) path)] - add (field@(index',sub_sel):fields) - | index == index' = (index',addRestriction sub_sel (path,n_index)):fields - | otherwise = field : add fields - - addProjection :: TermSelector -> FPath -> TermSelector - addProjection StrSel [] = StrSel - addProjection (TupleSel fields) (index : path) = TupleSel (add fields) - where - add [] = [(index,path2selector StrSel path)] - add (field@(index',sub_sel):fields) - | index == index' = (index',addProjection sub_sel path):fields - | otherwise = field : add fields - - path2selector base [] = base - path2selector base (index : path) = TupleSel [(index,path2selector base path)] - ------------------------------------------------------------- --- updating the MCF rule - -readArgCType :: FIndex -> CnvMonad Term -readArgCType nr = do (_, _, _, ctypes) <- readState - return (ctypes !! nr) - -restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () -restrictArg nr path index = do - (head, args, ctype, ctypes) <- readState - args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat - return (xcat,xs) ) nr args - writeState (head, args', ctype, ctypes) - -projectArg :: FIndex -> FPath -> CnvMonad Int -projectArg nr path = do - (head, args, ctype, ctypes) <- readState - (xnr,args') <- updateArgs nr args - writeState (head, args', ctype, ctypes) - return xnr - where - updateArgs :: FIndex -> [(ProtoFCat,[FPath])] -> CnvMonad (Int,[(ProtoFCat,[FPath])]) - updateArgs 0 ((a@(PFCat _ rcs _),xpaths) : as) - | path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as) - | otherwise = do a <- projectProtoFCat path a - return (0,(a,xpaths):as) - updateArgs n (a : as) = do - (xnr,as) <- updateArgs (n-1) as - return (xnr,a:as) - -readHeadCType :: CnvMonad Term -readHeadCType = do (_, _, ctype, _) <- readState - return ctype - -restrictHead :: FPath -> FIndex -> CnvMonad () -restrictHead path term - = do (head, args, ctype, ctypes) <- readState - head' <- restrictProtoFCat path term head - writeState (head', args, ctype, ctypes) - -projectHead :: FPath -> CnvMonad () -projectHead path - = do (head, args, ctype, ctypes) <- readState - head' <- projectProtoFCat path head - writeState (head', args, ctype, ctypes) - -restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat -restrictProtoFCat path0 index0 (PFCat cat rcs tcs) = do - tcs <- addConstraint tcs - return (PFCat cat rcs tcs) - where - addConstraint (c@(path,index) : cs) - | path0 > path = liftM (c:) (addConstraint cs) - | path0 == path = guard (index0 == index) >> - return (c : cs) - addConstraint cs = return ((path0,index0) : cs) - -projectProtoFCat :: FPath -> ProtoFCat -> CnvMonad ProtoFCat -projectProtoFCat path0 (PFCat cat rcs tcs) = do - return (PFCat cat (addConstraint rcs) tcs) - where - addConstraint (path : rcs) - | path0 > path = path : addConstraint rcs - | path0 == path = path : rcs - addConstraint rcs = path0 : rcs diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs deleted file mode 100644 index bbd3ae355..000000000 --- a/src/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/GF/Conversion/SimpleToMCFG.hs b/src/GF/Conversion/SimpleToMCFG.hs deleted file mode 100644 index 8f23c905d..000000000 --- a/src/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/GF/Conversion/SimpleToMCFG/Coercions.hs b/src/GF/Conversion/SimpleToMCFG/Coercions.hs deleted file mode 100644 index 319b99dcb..000000000 --- a/src/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/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs deleted file mode 100644 index d6ff052f5..000000000 --- a/src/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/GF/Conversion/SimpleToMCFG/Strict.hs b/src/GF/Conversion/SimpleToMCFG/Strict.hs deleted file mode 100644 index a5519fcd8..000000000 --- a/src/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/GF/Conversion/TypeGraph.hs b/src/GF/Conversion/TypeGraph.hs deleted file mode 100644 index 62ee9726e..000000000 --- a/src/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/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs deleted file mode 100644 index 97c2ace05..000000000 --- a/src/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.wildIdent [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/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs deleted file mode 100644 index f775319ea..000000000 --- a/src/GF/Data/Assoc.hs +++ /dev/null @@ -1,143 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Assoc --- Maintainer : Peter Ljunglöf --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- Association lists, or finite maps, --- including sets as maps with result type @()@. --- function names stolen from module @Array@. --- /O(log n)/ key lookup ------------------------------------------------------------------------------ - -module GF.Data.Assoc ( Assoc, - Set, - emptyAssoc, - emptySet, - listAssoc, - listSet, - accumAssoc, - aAssocs, - aElems, - assocMap, - assocFilter, - lookupAssoc, - lookupWith, - (?), - (?=) - ) where - -import GF.Data.SortedList - -infixl 9 ?, ?= - --- | a set is a finite map with empty values -type Set a = Assoc a () - -emptyAssoc :: Ord a => Assoc a b -emptySet :: Ord a => Set a - --- | creating a finite map from a sorted key-value list -listAssoc :: Ord a => SList (a, b) -> Assoc a b - --- | creating a set from a sorted list -listSet :: Ord a => SList a -> Set a - --- | building a finite map from a list of keys and 'b's, --- and a function that combines a sorted list of 'b's into a value -accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b - --- | all key-value pairs from an association list -aAssocs :: Ord a => Assoc a b -> SList (a, b) - --- | all keys from an association list -aElems :: Ord a => Assoc a b -> SList a - --- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b' - --- | mapping values to other values. --- the mapping function can take the key as information -assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b' - -assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b -assocFilter pred = listAssoc . filter (pred . snd) . aAssocs - --- | monadic lookup function, --- returning failure if the key does not exist -lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b - --- | if the key does not exist, --- the first argument is returned -lookupWith :: Ord a => b -> Assoc a b -> a -> b - --- | if the values are monadic, we can return the value type -(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b - --- | checking wheter the map contains a given key -(?=) :: Ord a => Assoc a b -> a -> Bool - - ------------------------------------------------------------- - -data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b) - deriving (Eq, Ord, Show) - -emptyAssoc = ANil -emptySet = emptyAssoc - -listAssoc as = assoc - where (assoc, []) = sl2bst (length as) as - sl2bst 0 xs = (ANil, xs) - sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs) - sl2bst n xs = (ANode left (fst x) (snd x) right, zs) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (left, x:ys) = sl2bst llen xs - (right, zs) = sl2bst rlen ys - -listSet as = listAssoc (zip as (repeat ())) - -accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort - where mapSnd f (a, b) = (a, f b) - -aAssocs as = prs as [] - where prs ANil = id - prs (ANode left a b right) = prs left . ((a,b) :) . prs right - -aElems = map fst . aAssocs - - -instance Ord a => Functor (Assoc a) where - fmap f = assocMap (const f) - -assocMap f ANil = ANil -assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right) - - -lookupAssoc ANil _ = fail "key not found" -lookupAssoc (ANode left a b right) a' = case compare a a' of - GT -> lookupAssoc left a' - LT -> lookupAssoc right a' - EQ -> return b - -lookupWith z ANil _ = z -lookupWith z (ANode left a b right) a' = case compare a a' of - GT -> lookupWith z left a' - LT -> lookupWith z right a' - EQ -> b - -(?) = lookupWith (fail "key not found") - -(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc - - - - - - - diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs deleted file mode 100644 index 790d11a83..000000000 --- a/src/GF/Data/BacktrackM.hs +++ /dev/null @@ -1,93 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : BacktrackM --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Backtracking state monad, with r\/o environment ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fglasgow-exts #-} -module GF.Data.BacktrackM ( -- * the backtracking state monad - BacktrackM, - -- * controlling the monad - failure, - (|||), - -- * handling the state & environment - readState, - writeState, - -- * monad specific utilities - member, - -- * running the monad - foldBM, runBM, - foldSolutions, solutions, - foldFinalStates, finalStates - ) where - -import Data.List -import Control.Monad - ----------------------------------------------------------------------- --- Combining endomorphisms and continuations --- a la Ralf Hinze - --- BacktrackM = state monad transformer over the backtracking monad - -newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b) - --- * running the monad - -runBM :: BacktrackM s a -> s -> [(s,a)] -runBM (BM m) s = m (\x s xs -> (s,x) : xs) s [] - -foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b -foldBM f b (BM m) s = m f s b - -foldSolutions :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b -foldSolutions f b (BM m) s = m (\x s b -> f x b) s b - -solutions :: BacktrackM s a -> s -> [a] -solutions = foldSolutions (:) [] - -foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b -foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b - -finalStates :: BacktrackM s () -> s -> [s] -finalStates bm = map fst . runBM bm - - --- * handling the state & environment - -readState :: BacktrackM s s -readState = BM (\c s b -> c s s b) - -writeState :: s -> BacktrackM s () -writeState s = BM (\c _ b -> c () s b) - -instance Monad (BacktrackM s) where - return a = BM (\c s b -> c a s b) - BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) - where unBM (BM m) = m - fail _ = failure - --- * controlling the monad - -failure :: BacktrackM s a -failure = BM (\c s b -> b) - -(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a -(BM f) ||| (BM g) = BM (\c s b -> g c s $! f c s b) - -instance MonadPlus (BacktrackM s) where - mzero = failure - mplus = (|||) - --- * specific functions on the backtracking monad - -member :: [a] -> BacktrackM s a -member xs = BM (\c s b -> foldl' (\b x -> c x s b) b xs) diff --git a/src/GF/Data/Compos.hs b/src/GF/Data/Compos.hs deleted file mode 100644 index 7d46fc5a2..000000000 --- a/src/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/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs deleted file mode 100644 index e8cea12d4..000000000 --- a/src/GF/Data/ErrM.hs +++ /dev/null @@ -1,38 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ErrM --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- hack for BNFC generated files. AR 21/9/2003 ------------------------------------------------------------------------------ - -module GF.Data.ErrM (Err(..)) where - -import Control.Monad (MonadPlus(..)) - --- | like @Maybe@ type with error msgs -data Err a = Ok a | Bad String - deriving (Read, Show, Eq) - -instance Monad Err where - return = Ok - fail = Bad - Ok a >>= f = f a - Bad s >>= f = Bad s - --- | added 2\/10\/2003 by PEB -instance Functor Err where - fmap f (Ok a) = Ok (f a) - fmap f (Bad s) = Bad s - --- | added by KJ -instance MonadPlus Err where - mzero = Bad "error (no reason given)" - mplus (Ok a) _ = Ok a - mplus (Bad s) b = b diff --git a/src/GF/Data/GeneralDeduction.hs b/src/GF/Data/GeneralDeduction.hs deleted file mode 100644 index 137212e5c..000000000 --- a/src/GF/Data/GeneralDeduction.hs +++ /dev/null @@ -1,121 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Simple implementation of deductive chart parsing ------------------------------------------------------------------------------ - -module GF.Data.GeneralDeduction - (-- * Type definition - ParseChart, - -- * Main functions - chartLookup, - buildChart, buildChartM, - -- * Probably not needed - emptyChart, - chartMember, - chartInsert, chartInsertM, - chartList, chartKeys, chartAssocs, - addToChart, addToChartM - ) where - --- import Trace - -import GF.Data.RedBlackSet -import Control.Monad (foldM) - ----------------------------------------------------------------------- --- main functions - -chartLookup :: (Ord item, Ord key) => ParseChart item key -> key -> [item] -chartList :: (Ord item, Ord key) => ParseChart item key -> [item] -chartKeys :: (Ord item, Ord key) => ParseChart item key -> [key] -chartAssocs :: (Ord item, Ord key) => ParseChart item key -> [(key,item)] -buildChart :: (Ord item, Ord key) => - (item -> key) -- ^ key lookup function - -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions - -- from triggering items to lists of items - -> [item] -- ^ initial chart - -> ParseChart item key -- ^ final chart -buildChartM :: (Ord item, Ord key) => - (item -> [key]) -- ^ many-valued key lookup function - -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions - -- from triggering items to lists of items - -> [item] -- ^ initial chart - -> ParseChart item key -- ^ final chart - -buildChart keyof rules axioms = 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 - -buildChartM keysof rules axioms = addItems axioms emptyChart - where addItems [] = id - addItems (item:items) = addItems items . addItem item - -- addItem item | trace ("+ "++show item++"\n") False = undefined - addItem item = addToChartM item (keysof item) - (\chart -> foldr (consequence item) chart rules) - consequence item rule chart = addItems (rule chart item) chart - --- probably not needed - -emptyChart :: (Ord item, Ord key) => ParseChart item key -chartMember :: (Ord item, Ord key) => ParseChart item key - -> item -> key -> Bool -chartInsert :: (Ord item, Ord key) => ParseChart item key - -> item -> key -> Maybe (ParseChart item key) -chartInsertM :: (Ord item, Ord key) => ParseChart item key - -> item -> [key] -> Maybe (ParseChart item key) - -addToChart :: (Ord item, Ord key) => item -> key - -> (ParseChart item key -> ParseChart item key) - -> ParseChart item key -> ParseChart item key -addToChart item keys after chart = maybe chart after (chartInsert chart item keys) - -addToChartM :: (Ord item, Ord key) => item -> [key] - -> (ParseChart item key -> ParseChart item key) - -> ParseChart item key -> ParseChart item key -addToChartM item keys after chart = maybe chart after (chartInsertM chart item keys) - - --------------------------------------------------------------------------------- --- key charts as red/black trees - -newtype ParseChart item key = KC (RedBlackMap key item) - deriving Show - -emptyChart = KC rbmEmpty -chartMember (KC tree) item key = rbmElem key item tree -chartLookup (KC tree) key = rbmLookup key tree -chartList (KC tree) = concatMap snd (rbmList tree) -chartKeys (KC tree) = map fst (rbmList tree) -chartAssocs (KC tree) = [(key,item) | (key,items) <- rbmList tree, item <- items] -chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree) - -chartInsertM (KC tree) item keys = fmap KC (foldM insertItem tree keys) - where insertItem tree key = rbmInsert key item 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/GF/Data/Glue.hs b/src/GF/Data/Glue.hs deleted file mode 100644 index 4f276222b..000000000 --- a/src/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/GF/Data/IncrementalDeduction.hs b/src/GF/Data/IncrementalDeduction.hs deleted file mode 100644 index d119610c1..000000000 --- a/src/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/GF/Data/Map.hs b/src/GF/Data/Map.hs deleted file mode 100644 index c86c9ab55..000000000 --- a/src/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/GF/Data/Operations.hs b/src/GF/Data/Operations.hs deleted file mode 100644 index 1b2033d69..000000000 --- a/src/GF/Data/Operations.hs +++ /dev/null @@ -1,658 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Operations --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 16:12:41 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.22 $ --- --- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001 --- --- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL) ------------------------------------------------------------------------------ - -module GF.Data.Operations (-- * misc functions - ifNull, onSnd, - - -- * the Error monad - Err(..), err, maybeErr, testErr, errVal, errIn, derrIn, - performOps, repeatUntilErr, repeatUntil, okError, isNotError, - showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList, - mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr, - (!?), errList, singleton, - - -- ** checking - checkUnique, titleIfNeeded, errMsg, errAndMsg, - - -- * a three-valued maybe type to express indirections - Perhaps(..), yes, may, nope, - mapP, - unifPerhaps, updatePerhaps, updatePerhapsHard, - - -- * binary search trees; now with FiniteMap - BinTree, emptyBinTree, isInBinTree, justLookupTree, - lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree, - buildTree, filterBinTree, - sorted2tree, mapTree, mapMTree, tree2list, - - - -- * parsing - WParser, wParseResults, paragraphs, - - -- * printing - indent, (+++), (++-), (++++), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, - - -- ** LaTeX code producing functions - dollar, mbox, ital, boldf, verbat, mkLatexFile, - begindocument, enddocument, - - -- * extra - sortByLongest, combinations, mkTextFile, initFilePath, - - -- * topological sorting with test of cyclicity - topoTest, topoSort, cyclesIn, - - -- * the generic fix point iterator - iterFix, - - -- * association lists - updateAssoc, removeAssoc, - - -- * chop into separator-separated parts - chunks, readIntArg, subSequences, - - -- * state monad with error; from Agda 6\/11\/2001 - STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done, - - -- * error monad class - ErrorMonad(..), checkAgain, checks, allChecks, doUntil - - ) where - -import Data.Char (isSpace, toUpper, isSpace, isDigit) -import Data.List (nub, sortBy, sort, deleteBy, nubBy) ---import Data.FiniteMap -import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) - -import GF.Data.ErrM - -infixr 5 +++ -infixr 5 ++- -infixr 5 ++++ -infixr 5 +++++ -infixl 9 !? - -ifNull :: b -> ([a] -> b) -> [a] -> b -ifNull b f xs = if null xs then b else f xs - -onSnd :: (a -> b) -> (c,a) -> (c,b) -onSnd f (x, y) = (x, f y) - --- the Error monad - --- | analogue of @maybe@ -err :: (String -> b) -> (a -> b) -> Err a -> b -err d f e = case e of - Ok a -> f a - Bad s -> d s - --- | add msg s to @Maybe@ failures -maybeErr :: String -> Maybe a -> Err a -maybeErr s = maybe (Bad s) Ok - -testErr :: Bool -> String -> Err () -testErr cond msg = if cond then return () else Bad msg - -errVal :: a -> Err a -> a -errVal a = err (const a) id - -errIn :: String -> Err a -> Err a -errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return - --- | used for extra error reports when developing GF -derrIn :: String -> Err a -> Err a -derrIn m = errIn m -- id - -performOps :: [a -> Err a] -> a -> Err a -performOps ops a = case ops of - f:fs -> f a >>= performOps fs - [] -> return a - -repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a -repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f - -repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a -repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a) - -okError :: Err a -> a --- okError = err (error "no result Ok") id -okError = err (error . ("Bad result occurred" ++++)) id - -isNotError :: Err a -> Bool -isNotError = err (const False) (const True) - -showBad :: Show a => String -> a -> Err b -showBad s a = Bad (s +++ show a) - -lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b -lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) - -lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b -lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs) - -lookupDefault :: Eq a => b -> a -> [(a,b)] -> b -lookupDefault d x l = maybe d id $ lookup x l - -updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] -updateLookupList ab abs = insert ab [] abs where - insert c cc [] = cc ++ [c] - insert (a,b) cc ((a',b'):cc') = if a == a' - then cc ++ [(a,b)] ++ cc' - else insert (a,b) (cc ++ [(a',b')]) cc' - -mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] -mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys - -mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys - -pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c) -pairM op (t1,t2) = liftM2 (,) (op t1) (op t2) - --- | like @mapM@, but continue instead of halting with 'Err' -mapErr :: (a -> Err b) -> [a] -> Err ([b], String) -mapErr f xs = Ok (ys, unlines ss) - where - (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) - fxs = map f xs - --- | alternative variant, peb 9\/6-04 -mapErrN :: Int -> (a -> Err b) -> [a] -> Err ([b], String) -mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2)) - where - (ys, ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) - errHdr = show nss ++ " errors occured" ++ - if nss > maxN then ", showing the first " ++ show maxN else "" - ss2 = map ("* "++) $ take maxN ss - nss = length ss - fxs = map f xs - --- | like @foldM@, but also return the latest value if fails -foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String) -foldErr f s xs = case xs of - [] -> return (s,Nothing) - x:xx -> case f s x of - Ok v -> foldErr f v xx - Bad m -> return $ (s, Just m) - --- @!!@ with the error monad -(!?) :: [a] -> Int -> Err a -xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs - -errList :: Err [a] -> [a] -errList = errVal [] - -singleton :: a -> [a] -singleton = (:[]) - --- checking - -checkUnique :: (Show a, Eq a) => [a] -> [String] -checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where - overloads = filter overloaded ss - overloaded s = length (filter (==s) ss) > 1 - -titleIfNeeded :: a -> [a] -> [a] -titleIfNeeded a [] = [] -titleIfNeeded a as = a:as - -errMsg :: Err a -> [String] -errMsg (Bad m) = [m] -errMsg _ = [] - -errAndMsg :: Err a -> Err (a,[String]) -errAndMsg (Bad m) = Bad m -errAndMsg (Ok a) = return (a,[]) - --- | a three-valued maybe type to express indirections -data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord) - -yes :: a -> Perhaps a b -yes = Yes - -may :: b -> Perhaps a b -may = May - -nope :: Perhaps a b -nope = Nope - -mapP :: (a -> c) -> Perhaps a b -> Perhaps c b -mapP f p = case p of - Yes a -> Yes (f a) - May b -> May b - Nope -> Nope - --- | this is what happens when matching two values in the same module -unifPerhaps :: (Eq a, Eq b, Show a, Show b) => - Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -unifPerhaps p1 p2 = case (p1,p2) of - (Nope, _) -> return p2 - (_, Nope) -> return p1 - _ -> if p1==p2 then return p1 - else Bad ("update conflict between" ++++ show p1 ++++ show p2) - --- | this is what happens when updating a module extension -updatePerhaps :: (Eq a,Eq b, Show a, Show b) => - b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -updatePerhaps old p1 p2 = case (p1,p2) of - (Yes a, Nope) -> return $ may old - (May older,Nope) -> return $ may older - (_, May a) -> Bad "strange indirection" - _ -> unifPerhaps p1 p2 - --- | here the value is copied instead of referred to; used for oper types -updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b -> - Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -updatePerhapsHard old p1 p2 = case (p1,p2) of - (Yes a, Nope) -> return $ yes a - (May older,Nope) -> return $ may older - (_, May a) -> Bad "strange indirection" - _ -> unifPerhaps p1 p2 - --- binary search trees ---- FiniteMap implementation is slower in crucial tests - -data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show) --- type BinTree a b = FiniteMap a b - -emptyBinTree :: BinTree a b -emptyBinTree = NT --- emptyBinTree = emptyFM - -isInBinTree :: (Ord a) => a -> BinTree a b -> Bool -isInBinTree x = err (const False) (const True) . justLookupTree x --- isInBinTree = elemFM - -justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b -justLookupTree = lookupTree (const []) - -lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b -lookupTree pr x tree = case tree of - NT -> fail ("no occurrence of element" +++ pr x) - BT (a,b) left right - | x < a -> lookupTree pr x left - | x > a -> lookupTree pr x right - | x == a -> return b ---lookupTree pr x tree = case lookupFM tree x of --- Just y -> return y --- _ -> fail ("no occurrence of element" +++ pr x) - -lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b -lookupTreeMany pr (t:ts) x = case lookupTree pr x t of - Ok v -> return v - _ -> lookupTreeMany pr ts x -lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x - -lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b] -lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of - Ok v -> v : lookupTreeManyAll pr ts x - _ -> lookupTreeManyAll pr ts x -lookupTreeManyAll pr [] x = [] - --- | destructive update -updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b --- updateTree (a,b) tr = addToFM tr a b -updateTree = updateTreeGen True - --- | destructive or not -updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree a b -> BinTree a b -updateTreeGen destr z@(x,y) tree = case tree of - NT -> BT z NT NT - BT c@(a,b) left right - | x < a -> let left' = updateTree z left in BT c left' right - | x > a -> let right' = updateTree z right in BT c left right' - | otherwise -> if destr - then BT z left right -- removing the old value of a - else tree -- retaining the old value if one exists - -buildTree :: (Ord a) => [(a,b)] -> BinTree a b -buildTree = sorted2tree . sortBy fs where - fs (x,_) (y,_) - | x < y = LT - | x > y = GT - | True = EQ --- buildTree = listToFM - -sorted2tree :: Ord a => [(a,b)] -> BinTree a b -sorted2tree [] = NT -sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where - (t1,(x:t2)) = splitAt (length xs `div` 2) xs ---sorted2tree = listToFM - ---- dm less general than orig -mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c -mapTree f NT = NT -mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) ---mapTree f = mapFM (\k v -> snd (f (k,v))) - ---- fm less efficient than orig? -mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c) -mapMTree f NT = return NT -mapMTree f (BT a left right) = do - a' <- f a - left' <- mapMTree f left - right' <- mapMTree f right - return $ BT a' left' right' ---mapMTree f t = liftM listToFM $ mapM f $ fmToList t - -filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b --- filterFM f t -filterBinTree f = sorted2tree . filter (uncurry f) . tree2list - -tree2list :: BinTree a b -> [(a,b)] -- inorder -tree2list NT = [] -tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right ---tree2list = fmToList - --- parsing - -type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser - -wParseResults :: WParser a b -> [a] -> [b] -wParseResults p aa = [b | (b,[]) <- p aa] - -paragraphs :: String -> [String] -paragraphs = map unlines . chop . lines where - chop [] = [] - chop ss = let (ps,rest) = break empty ss in ps : chop (dropWhile empty rest) - empty = all isSpace - --- printing - -indent :: Int -> String -> String -indent i s = replicate i ' ' ++ s - -(+++), (++-), (++++), (+++++) :: String -> String -> String -a +++ b = a ++ " " ++ b -a ++- "" = a -a ++- b = a +++ b -a ++++ b = a ++ "\n" ++ b -a +++++ b = a ++ "\n\n" ++ b - -prUpper :: String -> String -prUpper s = s1 ++ s2' where - (s1,s2) = span isSpace s - s2' = case s2 of - c:t -> toUpper c : t - _ -> s2 - -prReplicate :: Int -> String -> String -prReplicate n s = concat (replicate n s) - -prTList :: String -> [String] -> String -prTList t ss = case ss of - [] -> "" - [s] -> s - s:ss -> s ++ t ++ prTList t ss - -prQuotedString :: String -> String -prQuotedString x = "\"" ++ restoreEscapes x ++ "\"" - -prParenth :: String -> String -prParenth s = if s == "" then "" else "(" ++ s ++ ")" - -prCurly, prBracket :: String -> String -prCurly s = "{" ++ s ++ "}" -prBracket s = "[" ++ s ++ "]" - -prArgList, prSemicList, prCurlyList :: [String] -> String -prArgList = prParenth . prTList "," -prSemicList = prTList " ; " -prCurlyList = prCurly . prSemicList - -restoreEscapes :: String -> String -restoreEscapes s = - case s of - [] -> [] - '"' : t -> '\\' : '"' : restoreEscapes t - '\\': t -> '\\' : '\\' : restoreEscapes t - c : t -> c : restoreEscapes t - -numberedParagraphs :: [[String]] -> [String] -numberedParagraphs t = case t of - [] -> [] - p:[] -> p - _ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t] - -prConjList :: String -> [String] -> String -prConjList c [] = "" -prConjList c [s] = s -prConjList c [s,t] = s +++ c +++ t -prConjList c (s:tt) = s ++ "," +++ prConjList c tt - -prIfEmpty :: String -> String -> String -> String -> String -prIfEmpty em _ _ [] = em -prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2 - --- | Thomas Hallgren's wrap lines -wrapLines :: Int -> String -> String -wrapLines n "" = "" -wrapLines n s@(c:cs) = - if isSpace c - then c:wrapLines (n+1) cs - else case lex s of - [(w,rest)] -> if n'>=76 - then '\n':w++wrapLines l rest - else w++wrapLines n' rest - where n' = n+l - l = length w - _ -> s -- give up!! - ---- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id - --- LaTeX code producing functions -dollar, mbox, ital, boldf, verbat :: String -> String -dollar s = '$' : s ++ "$" -mbox s = "\\mbox{" ++ s ++ "}" -ital s = "{\\em" +++ s ++ "}" -boldf s = "{\\bf" +++ s ++ "}" -verbat s = "\\verbat!" ++ s ++ "!" - -mkLatexFile :: String -> String -mkLatexFile s = begindocument +++++ s +++++ enddocument - -begindocument, enddocument :: String -begindocument = - "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02 - "\\setlength{\\parskip}{2mm}" ++++ - "\\setlength{\\parindent}{0mm}" ++++ - "\\setlength{\\oddsidemargin}{0mm}" ++++ - ("\\setlength{\\evensidemargin}{"++"-2mm}") ++++ -- peb 27/5-04: to prevent hugs-mode - ("\\setlength{\\topmargin}{"++"-8mm}") ++++ -- from treating the rest as comments - "\\setlength{\\textheight}{240mm}" ++++ - "\\setlength{\\textwidth}{158mm}" ++++ - "\\begin{document}\n" -enddocument = - "\n\\end{document}\n" - - -sortByLongest :: [[a]] -> [[a]] -sortByLongest = sortBy longer where - longer x y - | x' > y' = LT - | x' < y' = GT - | True = EQ - where - x' = length x - y' = length y - --- | 'combinations' is the same as @sequence@!!! --- peb 30\/5-04 -combinations :: [[a]] -> [[a]] -combinations t = case t of - [] -> [[]] - aa:uu -> [a:u | a <- aa, u <- combinations uu] - - -mkTextFile :: String -> IO () -mkTextFile name = do - s <- readFile name - let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s - writeFile (name ++ ".hs") s' - where - prelude name = "module " ++ name ++ " where" - heading name = "txt" ++ name ++ " =" - object s = mk s ++ " \"\"" - mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s] - escs s = case s of - c:cs | elem c "\"\\" -> '\\' : c : escs cs - c:cs -> c : escs cs - _ -> s - -initFilePath :: FilePath -> FilePath -initFilePath f = reverse (dropWhile (/='/') (reverse f)) - --- | topological sorting with test of cyclicity -topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]] -topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) - where - g' = topoSort g - -cyclesIn :: Eq a => [(a,[a])] -> [[a]] -cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where - immediate = [[y,x] | (x,xs) <- deps, y <- xs] - findDep chains = [y:x:chain | - x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, - notElem y (init chain)] - - clean = map remdup - nubb = nubBy (\x y -> y == reverse x) - filt = filter (\xs -> last xs == head xs) - remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs - remdup [] = [] - - --- | topological sorting -topoSort :: Eq a => [(a,[a])] -> [a] -topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where - tsort _ [] r = r - tsort k (ffs@(f,fs) : cs) r - | elem f r = tsort k cs r - | k > lx = r - | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r) - info hs = [(f,fs) | (f,fs) <- g, elem f hs] - inDeg f = length [t | (h,hs) <- g, t <- hs, t == f] - lx = length g - --- | the generic fix point iterator -iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] -iterFix more start = iter start start - where - iter old new = if (null new') - then old - else iter (new' ++ old) new' - where - new' = filter (`notElem` old) (more new) - --- association lists - -updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] -updateAssoc ab@(a,b) as = case as of - (x,y): xs | x == a -> (a,b):xs - xy : xs -> xy : updateAssoc ab xs - [] -> [ab] - -removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)] -removeAssoc a = filter ((/=a) . fst) - --- | chop into separator-separated parts -chunks :: Eq a => a -> [a] -> [[a]] -chunks sep ws = case span (/= sep) ws of - (a,_:b) -> a : bs where bs = chunks sep b - (a, []) -> if null a then [] else [a] - -readIntArg :: String -> Int -readIntArg n = if (not (null n) && all isDigit n) then read n else 0 - - --- state monad with error; from Agda 6/11/2001 - -newtype STM s a = STM (s -> Err (a,s)) - -appSTM :: STM s a -> s -> Err (a,s) -appSTM (STM f) s = f s - -stm :: (s -> Err (a,s)) -> STM s a -stm = STM - -stmr :: (s -> (a,s)) -> STM s a -stmr f = stm (\s -> return (f s)) - -instance Monad (STM s) where - return a = STM (\s -> return (a,s)) - STM c >>= f = STM (\s -> do - (x,s') <- c s - let STM f' = f x - f' s') - -readSTM :: STM s s -readSTM = stmr (\s -> (s,s)) - -updateSTM :: (s -> s) -> STM s () -updateSTM f = stmr (\s -> ((),f s)) - -writeSTM :: s -> STM s () -writeSTM s = stmr (const ((),s)) - -done :: Monad m => m () -done = return () - -class Monad m => ErrorMonad m where - raise :: String -> m a - handle :: m a -> (String -> m a) -> m a - handle_ :: m a -> m a -> m a - handle_ a b = a `handle` (\_ -> b) - -instance ErrorMonad Err where - raise = Bad - handle a@(Ok _) _ = a - handle (Bad i) f = f i - -instance ErrorMonad (STM s) where - raise msg = STM (\s -> raise msg) - handle (STM f) g = STM (\s -> (f s) - `handle` (\e -> let STM g' = (g e) in - g' s)) - --- | if the first check fails try another one -checkAgain :: ErrorMonad m => m a -> m a -> m a -checkAgain c1 c2 = handle_ c1 c2 - -checks :: ErrorMonad m => [m a] -> m a -checks [] = raise "no chance to pass" -checks cs = foldr1 checkAgain cs - -allChecks :: ErrorMonad m => [m a] -> m [a] -allChecks ms = case ms of - (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs - _ -> return [] - -doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a -doUntil cond ms = case ms of - a:as -> do - v <- a - if cond v then return v else doUntil cond as - _ -> raise "no result" - --- subsequences sorted from longest to shortest ; their number is 2^n -subSequences :: [a] -> [[a]] -subSequences = sortBy (\x y -> compare (length y) (length x)) . subs where - subs xs = case xs of - [] -> [[]] - x:xs -> let xss = subs xs in [x:y | y <- xss] ++ xss diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs deleted file mode 100644 index 3590f0584..000000000 --- a/src/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/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs deleted file mode 100644 index 34eb0705d..000000000 --- a/src/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/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs deleted file mode 100644 index f9bf02598..000000000 --- a/src/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/GF/Data/RedBlack.hs b/src/GF/Data/RedBlack.hs deleted file mode 100644 index fd70dba63..000000000 --- a/src/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/GF/Data/RedBlackSet.hs b/src/GF/Data/RedBlackSet.hs deleted file mode 100644 index 8a1b8a743..000000000 --- a/src/GF/Data/RedBlackSet.hs +++ /dev/null @@ -1,150 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : RedBlackSet --- Maintainer : Peter Ljunglöf --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/03/21 14:17:39 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Modified version of Okasaki's red-black trees --- incorporating sets and set-valued maps ----------------------------------------------------------------------- - -module GF.Data.RedBlackSet ( -- * Red-black sets - RedBlackSet, - rbEmpty, - rbList, - rbElem, - rbLookup, - rbInsert, - rbMap, - rbOrdMap, - -- * Red-black finite maps - RedBlackMap, - rbmEmpty, - rbmList, - rbmElem, - rbmLookup, - rbmInsert, - rbmOrdMap - ) where - --------------------------------------------------------------------------------- --- sets - -data Color = R | B deriving (Eq, Show) -data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a) - deriving (Eq, Show) - -rbBalance 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) -rbBalance 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) -rbBalance 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) -rbBalance 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) -rbBalance color a x b = T color a x b - -rbBlack (T _ a x b) = T B a x b - --- | the empty set -rbEmpty :: RedBlackSet a -rbEmpty = E - --- | the elements of a set as a sorted list -rbList :: RedBlackSet a -> [a] -rbList tree = rbl tree [] - where rbl E = id - rbl (T _ left a right) = rbl right . (a:) . rbl left - --- | checking for containment -rbElem :: Ord a => a -> RedBlackSet a -> Bool -rbElem _ E = False -rbElem a (T _ left a' right) - = case compare a a' of - LT -> rbElem a left - GT -> rbElem a right - EQ -> True - --- | looking up a key in a set of keys and values -rbLookup :: Ord k => k -> RedBlackSet (k, a) -> Maybe a -rbLookup _ E = Nothing -rbLookup a (T _ left (a',b) right) - = case compare a a' of - LT -> rbLookup a left - GT -> rbLookup a right - EQ -> Just b - --- | inserting a new element. --- returns 'Nothing' if the element is already contained -rbInsert :: Ord a => a -> RedBlackSet a -> Maybe (RedBlackSet a) -rbInsert value tree = fmap rbBlack (rbins tree) - where rbins E = Just (T R E value E) - rbins (T color left value' right) - = case compare value value' of - LT -> do left' <- rbins left - return (rbBalance color left' value' right) - GT -> do right' <- rbins right - return (rbBalance color left value' right') - EQ -> Nothing - --- | mapping each value of a key-value set -rbMap :: (a -> b) -> RedBlackSet (k, a) -> RedBlackSet (k, b) -rbMap f E = E -rbMap f (T color left (key, value) right) - = T color (rbMap f left) (key, f value) (rbMap f right) - --- | mapping each element to another type. --- /observe/ that the mapping function needs to preserve --- the order between objects -rbOrdMap :: (a -> b) -> RedBlackSet a -> RedBlackSet b -rbOrdMap f E = E -rbOrdMap f (T color left value right) - = T color (rbOrdMap f left) (f value) (rbOrdMap f right) - ----------------------------------------------------------------------- --- finite maps - -type RedBlackMap k a = RedBlackSet (k, RedBlackSet a) - --- | the empty map -rbmEmpty :: RedBlackMap k a -rbmEmpty = E - --- | converting a map to a key-value list, sorted on the keys, --- and for each key, a sorted list of values -rbmList :: RedBlackMap k a -> [(k, [a])] -rbmList tree = [ (k, rbList sub) | (k, sub) <- rbList tree ] - --- | checking whether a key-value pair is contained in the map -rbmElem :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Bool -rbmElem key value = maybe False (rbElem value) . rbLookup key - --- | looking up a key, returning a (sorted) list of all matching values -rbmLookup :: Ord k => k -> RedBlackMap k a -> [a] -rbmLookup key = maybe [] rbList . rbLookup key - --- | inserting a key-value pair. --- returns 'Nothing' if the pair is already contained in the map -rbmInsert :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Maybe (RedBlackMap k a) -rbmInsert key value tree = fmap rbBlack (rbins tree) - where rbins E = Just (T R E (key, T B E value E) E) - rbins (T color left item@(key', vtree) right) - = case compare key key' of - LT -> do left' <- rbins left - return (rbBalance color left' item right) - GT -> do right' <- rbins right - return (rbBalance color left item right') - EQ -> do vtree' <- rbInsert value vtree - return (T color left (key', vtree') right) - --- | mapping each value to another type. --- /observe/ that the mapping function needs to preserve --- order between objects -rbmOrdMap :: (a -> b) -> RedBlackMap k a -> RedBlackMap k b -rbmOrdMap f E = E -rbmOrdMap f (T color left (key, tree) right) - = T color (rbmOrdMap f left) (key, rbOrdMap f tree) (rbmOrdMap f right) - - - diff --git a/src/GF/Data/SharedString.hs b/src/GF/Data/SharedString.hs deleted file mode 100644 index 9d037b512..000000000 --- a/src/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/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs deleted file mode 100644 index d77ff68d4..000000000 --- a/src/GF/Data/SortedList.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : stable --- Portability : portable --- --- > CVS $Date: 2005/04/21 16:22:08 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Sets as sorted lists --- --- * /O(n)/ union, difference and intersection --- --- * /O(n log n)/ creating a set from a list (=sorting) --- --- * /O(n^2)/ fixed point iteration ------------------------------------------------------------------------------ - -module GF.Data.SortedList - ( -- * type declarations - SList, SMap, - -- * set operations - nubsort, union, - (<++>), (<\\>), (<**>), - limit, - hasCommonElements, subset, - -- * map operations - groupPairs, groupUnion, - unionMap, mergeMap - ) where - -import Data.List (groupBy) -import GF.Data.Utilities (split, foldMerge) - --- | The list must be sorted and contain no duplicates. -type SList a = [a] - --- | A sorted map also has unique keys, --- i.e. 'map fst m :: SList a', if 'm :: SMap a b' -type SMap a b = SList (a, b) - --- | Group a set of key-value pairs into a sorted map -groupPairs :: Ord a => SList (a, b) -> SMap a (SList b) -groupPairs = map mapFst . groupBy eqFst - where mapFst as = (fst (head as), map snd as) - eqFst a b = fst a == fst b - --- | Group a set of key-(sets-of-values) pairs into a sorted map -groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b) -groupUnion = map unionSnd . groupPairs - where unionSnd (a, bs) = (a, union bs) - --- | True is the two sets has common elements -hasCommonElements :: Ord a => SList a -> SList a -> Bool -hasCommonElements as bs = not (null (as <**> bs)) - --- | True if the first argument is a subset of the second argument -subset :: Ord a => SList a -> SList a -> Bool -xs `subset` ys = null (xs <\\> ys) - --- | Create a set from any list. --- This function can also be used as an alternative to @nub@ in @List.hs@ -nubsort :: Ord a => [a] -> SList a -nubsort = union . map return - --- | the union of a list of sorted maps -unionMap :: Ord a => (b -> b -> b) - -> [SMap a b] -> SMap a b -unionMap plus = foldMerge (mergeMap plus) [] - --- | merging two sorted maps -mergeMap :: Ord a => (b -> b -> b) - -> SMap a b -> SMap a b -> SMap a b -mergeMap plus [] abs = abs -mergeMap plus abs [] = abs -mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds') - = case compare a c of - EQ -> (a, plus bs ds) : mergeMap plus abs' cds' - LT -> ab : mergeMap plus abs' cds - GT -> cd : mergeMap plus abs cds' - --- | The union of a list of sets -union :: Ord a => [SList a] -> SList a -union = foldMerge (<++>) [] - --- | The union of two sets -(<++>) :: Ord a => SList a -> SList a -> SList a -[] <++> bs = bs -as <++> [] = as -as@(a:as') <++> bs@(b:bs') = case compare a b of - LT -> a : (as' <++> bs) - GT -> b : (as <++> bs') - EQ -> a : (as' <++> bs') - --- | The difference of two sets -(<\\>) :: Ord a => SList a -> SList a -> SList a -[] <\\> bs = [] -as <\\> [] = as -as@(a:as') <\\> bs@(b:bs') = case compare a b of - LT -> a : (as' <\\> bs) - GT -> (as <\\> bs') - EQ -> (as' <\\> bs') - --- | The intersection of two sets -(<**>) :: Ord a => SList a -> SList a -> SList a -[] <**> bs = [] -as <**> [] = [] -as@(a:as') <**> bs@(b:bs') = case compare a b of - LT -> (as' <**> bs) - GT -> (as <**> bs') - EQ -> a : (as' <**> bs') - --- | A fixed point iteration -limit :: Ord a => (a -> SList a) -- ^ The iterator function - -> SList a -- ^ The initial set - -> SList a -- ^ The result of the iteration -limit more start = limit' start start - where limit' chart agenda | null new' = chart - | otherwise = limit' (chart <++> new') new' - where new = union (map more agenda) - new'= new <\\> chart - - - - - diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs deleted file mode 100644 index 6f65764c7..000000000 --- a/src/GF/Data/Str.hs +++ /dev/null @@ -1,134 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Str --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Str ( - Str (..), Tok (..), --- constructors needed in PrGrammar - str2strings, str2allStrings, str, sstr, sstrV, - isZeroTok, prStr, plusStr, glueStr, - strTok, - allItems -) where - -import GF.Data.Operations -import Data.List (isPrefixOf, isSuffixOf, intersperse) - --- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003 -newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord) - --- | notice that having both pre and post would leave to inconsistent situations: --- --- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"} --- --- always violates a condition expressed by the one or the other -data Tok = - TK String - | TN Ss [(Ss, [String])] -- ^ variants depending on next string ---- | TP Ss [(Ss, [String])] -- variants depending on previous string - deriving (Eq, Ord, Show, Read) - - --- | a variant can itself be a token list, but for simplicity only a list of strings --- i.e. not itself containing variants -type Ss = [String] - --- matching functions in both ways - -matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss -matchPrefix s vs t = - head $ [u | - (u,as) <- vs, - any (\c -> isPrefixOf c (concat (unmarkup t))) as - ] ++ [s] - -matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss -matchSuffix t s vs = - head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s]) - -unmarkup :: [String] -> [String] -unmarkup = filter (not . isXMLtag) where - isXMLtag s = case s of - '<':cs@(_:_) -> last cs == '>' - _ -> False - -str2strings :: Str -> Ss -str2strings (Str st) = alls st where - alls st = case st of - TK s : ts -> s : alls ts - TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts ----- u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts - [] -> [] - -str2allStrings :: Str -> [Ss] -str2allStrings (Str st) = alls st where - alls st = case st of - TK s : ts -> [s : t | t <- alls ts] - TN ds vs : [] -> [ds ++ v | v <- map fst vs] - TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts] - [] -> [[]] - -sstr :: Str -> String -sstr = unwords . str2strings - --- | to handle a list of variants -sstrV :: [Str] -> String -sstrV ss = case ss of - [] -> "*" - _ -> unwords $ intersperse "/" $ map (unwords . str2strings) ss - -str :: String -> Str -str s = if null s then Str [] else Str [itS s] - -itS :: String -> Tok -itS s = TK s - -isZeroTok :: Str -> Bool -isZeroTok t = case t of - Str [] -> True - Str [TK []] -> True - _ -> False - -strTok :: Ss -> [(Ss,[String])] -> Str -strTok ds vs = Str [TN ds vs] - -prStr :: Str -> String -prStr = prQuotedString . sstr - -plusStr :: Str -> Str -> Str -plusStr (Str ss) (Str tt) = Str (ss ++ tt) - -glueStr :: Str -> Str -> Str -glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of - ([],_) -> tt - (_,[]) -> ss - _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt - where - glueIt t u = case (t,u) of - (TK s, TK s') -> return $ TK $ s ++ s' - (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) - [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws] - (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s] - (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws] - -glues :: [[a]] -> [[a]] -> [[a]] -glues ss tt = case (ss,tt) of - ([],_) -> tt - (_,[]) -> ss - _ -> init ss ++ [last ss ++ head tt] ++ tail tt - --- | to create the list of all lexical items -allItems :: Str -> [String] -allItems (Str s) = concatMap allOne s where - allOne t = case t of - TK s -> [s] - TN ds vs -> ds ++ concatMap fst vs diff --git a/src/GF/Data/Trie.hs b/src/GF/Data/Trie.hs deleted file mode 100644 index 9fb5daa27..000000000 --- a/src/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/GF/Data/Trie2.hs b/src/GF/Data/Trie2.hs deleted file mode 100644 index 36fcc3221..000000000 --- a/src/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/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs deleted file mode 100644 index 74d3ef81e..000000000 --- a/src/GF/Data/Utilities.hs +++ /dev/null @@ -1,190 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/26 18:47:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Basic functions not in the standard libraries ------------------------------------------------------------------------------ - - -module GF.Data.Utilities where - -import Data.Maybe -import Data.List -import Control.Monad (MonadPlus(..),liftM) - --- * functions on lists - -sameLength :: [a] -> [a] -> Bool -sameLength [] [] = True -sameLength (_:xs) (_:ys) = sameLength xs ys -sameLength _ _ = False - -notLongerThan, longerThan :: Int -> [a] -> Bool -notLongerThan n = null . snd . splitAt n -longerThan n = not . notLongerThan n - -lookupList :: Eq a => a -> [(a, b)] -> [b] -lookupList a [] = [] -lookupList a (p:ps) | a == fst p = snd p : lookupList a ps - | otherwise = lookupList a ps - -split :: [a] -> ([a], [a]) -split (x : y : as) = (x:xs, y:ys) - where (xs, ys) = split as -split as = (as, []) - -splitBy :: (a -> Bool) -> [a] -> ([a], [a]) -splitBy p [] = ([], []) -splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys) - where (xs, ys) = splitBy p as - -foldMerge :: (a -> a -> a) -> a -> [a] -> a -foldMerge merge zero = fm - where fm [] = zero - fm [a] = a - fm abs = let (as, bs) = split abs in fm as `merge` fm bs - -select :: [a] -> [(a, [a])] -select [] = [] -select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ] - -updateNth :: (a -> a) -> Int -> [a] -> [a] -updateNth update 0 (a : as) = update a : as -updateNth update n (a : as) = a : updateNth update (n-1) as - -updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a] -updateNthM update 0 (a : as) = liftM (:as) (update a) -updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as) - --- | Like 'init', but returns the empty list when the input is empty. -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit xs = init xs - --- | Like 'nub', but more efficient as it uses sorting internally. -sortNub :: Ord a => [a] -> [a] -sortNub = map head . group . sort - --- | Like 'nubBy', but more efficient as it uses sorting internally. -sortNubBy :: (a -> a -> Ordering) -> [a] -> [a] -sortNubBy f = map head . sortGroupBy f - --- | Sorts and then groups elements given and ordering of the --- elements. -sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]] -sortGroupBy f = groupBy (compareEq f) . sortBy f - --- | Take the union of a list of lists. -unionAll :: Eq a => [[a]] -> [a] -unionAll = nub . concat - --- | Like 'lookup', but fails if the argument is not found, --- instead of returning Nothing. -lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b -lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x - --- | Like 'find', but fails if nothing is found. -find' :: (a -> Bool) -> [a] -> a -find' p = fromJust . find p - --- | Set a value in a lookup table. -tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)] -tableSet x y [] = [(x,y)] -tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs - | otherwise = p:tableSet x y xs - --- | Group tuples by their first elements. -buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])] -buildMultiMap = map (\g -> (fst (head g), map snd g) ) - . sortGroupBy (compareBy fst) - --- | Replace all occurences of an element by another element. -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - --- * equality functions - --- | Use an ordering function as an equality predicate. -compareEq :: (a -> a -> Ordering) -> a -> a -> Bool -compareEq f x y = case f x y of - EQ -> True - _ -> False - --- * ordering functions - -compareBy :: Ord b => (a -> b) -> a -> a -> Ordering -compareBy f = both f compare - -both :: (a -> b) -> (b -> b -> c) -> a -> a -> c -both f g x y = g (f x) (f y) - --- * functions on pairs - -mapFst :: (a -> a') -> (a, b) -> (a', b) -mapFst f (a, b) = (f a, b) - -mapSnd :: (b -> b') -> (a, b) -> (a, b') -mapSnd f (a, b) = (a, f b) - --- * functions on monads - --- | Return the given value if the boolean is true, els return 'mzero'. -whenMP :: MonadPlus m => Bool -> a -> m a -whenMP b x = if b then return x else mzero - --- * functions on Maybes - --- | Returns true if the argument is Nothing or Just [] -nothingOrNull :: Maybe [a] -> Bool -nothingOrNull = maybe True null - --- * functions on functions - --- | Apply all the functions in the list to the argument. -foldFuns :: [a -> a] -> a -> a -foldFuns fs x = foldl (flip ($)) x fs - --- | Fixpoint iteration. -fix :: Eq a => (a -> a) -> a -> a -fix f x = let x' = f x in if x' == x then x else fix f x' - --- * functions on strings - --- | Join a number of lists by using the given glue --- between the lists. -join :: [a] -- ^ glue - -> [[a]] -- ^ lists to join - -> [a] -join g = concat . intersperse g - --- * ShowS-functions - -nl :: ShowS -nl = showChar '\n' - -sp :: ShowS -sp = showChar ' ' - -wrap :: String -> ShowS -> String -> ShowS -wrap o s c = showString o . s . showString c - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -unwordsS :: [ShowS] -> ShowS -unwordsS = joinS " " - -unlinesS :: [ShowS] -> ShowS -unlinesS = joinS "\n" - -joinS :: String -> [ShowS] -> ShowS -joinS glue = concatS . intersperse (showString glue) - - - diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs deleted file mode 100644 index a1807adcc..000000000 --- a/src/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/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs deleted file mode 100644 index a4491f76e..000000000 --- a/src/GF/Data/Zipper.hs +++ /dev/null @@ -1,257 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Zipper --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/11 20:27:05 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001 ------------------------------------------------------------------------------ - -module GF.Data.Zipper (-- * types - Tr(..), - Path(..), - Loc(..), - -- * basic (original) functions - leaf, - goLeft, goRight, goUp, goDown, - changeLoc, - changeNode, - forgetNode, - -- * added sequential representation - goAhead, - goBack, - -- ** n-ary versions - goAheadN, - goBackN, - -- * added mappings between locations and trees - loc2tree, - loc2treeMarked, - tree2loc, - goRoot, - goLast, - goPosition, - getPosition, - keepPosition, - -- * added some utilities - traverseCollect, - scanTree, - mapTr, - mapTrM, - mapPath, - mapPathM, - mapLoc, - mapLocM, - foldTr, - foldTrM, - mapSubtrees, - mapSubtreesM, - changeRoot, - nthSubtree, - arityTree - ) where - -import GF.Data.Operations - -newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq) - -data Path a = - Top - | Node ([Tr a], (Path a, a), [Tr a]) - deriving Show - -leaf :: a -> Tr a -leaf a = Tr (a,[]) - -newtype Loc a = Loc (Tr a, Path a) deriving Show - -goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a) -goLeft (Loc (t,p)) = case p of - Top -> Bad "left of top" - Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right)) - Node _ -> Bad "left of first" -goRight (Loc (t,p)) = case p of - Top -> Bad "right of top" - Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right)) - Node _ -> Bad "right of first" -goUp (Loc (t,p)) = case p of - Top -> Bad "up of top" - Node (left, (up,v), right) -> - return $ Loc (Tr (v, reverse left ++ (t:right)), up) -goDown (Loc (t,p)) = case t of - Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees)) - _ -> Bad "down of empty" - -changeLoc :: Loc a -> Tr a -> Err (Loc a) -changeLoc (Loc (_,p)) t = return $ Loc (t,p) - -changeNode :: (a -> a) -> Loc a -> Loc a -changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p) - -forgetNode :: Loc a -> Err (Loc a) -forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p) -forgetNode _ = Bad $ "not a one-branch tree" - --- added sequential representation - --- | a successor function -goAhead :: Loc a -> Err (Loc a) -goAhead s@(Loc (t,p)) = case (t,p) of - (Tr (_,_:_),Node (_,_,_:_)) -> goDown s - (Tr (_,[]), _) -> upsRight s - (_, _) -> goDown s - where - upsRight t = case goRight t of - Ok t' -> return t' - Bad _ -> goUp t >>= upsRight - --- | a predecessor function -goBack :: Loc a -> Err (Loc a) -goBack s@(Loc (t,p)) = case goLeft s of - Ok s' -> downRight s' - _ -> goUp s - where - downRight s = case goDown s of - Ok s' -> case goRight s' of - Ok s'' -> downRight s'' - _ -> downRight s' - _ -> return s - --- n-ary versions - -goAheadN :: Int -> Loc a -> Err (Loc a) -goAheadN i st - | i < 1 = return st - | otherwise = goAhead st >>= goAheadN (i-1) - -goBackN :: Int -> Loc a -> Err (Loc a) -goBackN i st - | i < 1 = return st - | otherwise = goBack st >>= goBackN (i-1) - --- added mappings between locations and trees - -loc2tree :: Loc a -> Tr a -loc2tree (Loc (t,p)) = case p of - Top -> t - Node (left,(p',v),right) -> - loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p')) - -loc2treeMarked :: Loc a -> Tr (a, Bool) -loc2treeMarked (Loc (Tr (a,ts),p)) = - loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) - where - (mark, nomark) = (\a -> (a,True), \a -> (a, False)) - -tree2loc :: Tr a -> Loc a -tree2loc t = Loc (t,Top) - -goRoot :: Loc a -> Loc a -goRoot = tree2loc . loc2tree - -goLast :: Loc a -> Err (Loc a) -goLast = rep goAhead where - rep f s = err (const (return s)) (rep f) (f s) - -goPosition :: [Int] -> Loc a -> Err (Loc a) -goPosition p = go p . goRoot where - go [] s = return s - go (p:ps) s = goDown s >>= apply p goRight >>= go ps - -getPosition :: Loc a -> [Int] -getPosition = reverse . getp where - getp (Loc (t,p)) = case p of - Top -> [] - Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p')) - -keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a)) -keepPosition f s = do - let p = getPosition s - s' <- f s - goPosition p s' - -apply :: Monad m => Int -> (a -> m a) -> a -> m a -apply n f a = case n of - 0 -> return a - _ -> f a >>= apply (n-1) f - --- added some utilities - -traverseCollect :: Path a -> [a] -traverseCollect p = reverse $ case p of - Top -> [] - Node (_, (p',v), _) -> v : traverseCollect p' - -scanTree :: Tr a -> [a] -scanTree (Tr (a,ts)) = a : concatMap scanTree ts - -mapTr :: (a -> b) -> Tr a -> Tr b -mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts) - -mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b) -mapTrM f (Tr (x,ts)) = do - fx <- f x - fts <- mapM (mapTrM f) ts - return $ Tr (fx,fts) - -mapPath :: (a -> b) -> Path a -> Path b -mapPath f p = case p of - Node (ts1, (p,v), ts2) -> - Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2) - Top -> Top - -mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b) -mapPathM f p = case p of - Node (ts1, (p,v), ts2) -> do - ts1' <- mapM (mapTrM f) ts1 - p' <- mapPathM f p - v' <- f v - ts2' <- mapM (mapTrM f) ts2 - return $ Node (ts1', (p',v'), ts2') - Top -> return Top - -mapLoc :: (a -> b) -> Loc a -> Loc b -mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p) - -mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b) -mapLocM f (Loc (t,p)) = do - t' <- mapTrM f t - p' <- mapPathM f p - return $ (Loc (t',p')) - -foldTr :: (a -> [b] -> b) -> Tr a -> b -foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts) - -foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b -foldTrM f (Tr (x,ts)) = do - fts <- mapM (foldTrM f) ts - f x fts - -mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a -mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts) - -mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a) -mapSubtreesM f t = do - Tr (x,ts) <- f t - ts' <- mapM (mapSubtreesM f) ts - return $ Tr (x, ts') - --- | change the root without moving the pointer -changeRoot :: (a -> a) -> Loc a -> Loc a -changeRoot f loc = case loc of - Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top) - Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right)) - where - chPath pv = case pv of - (Top,a) -> (Top, f a) - (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v) - -nthSubtree :: Int -> Tr a -> Err (Tr a) -nthSubtree n (Tr (a,ts)) = ts !? n - -arityTree :: Tr a -> Int -arityTree (Tr (_,ts)) = length ts diff --git a/src/GF/Devel/AbsCompute.hs b/src/GF/Devel/AbsCompute.hs deleted file mode 100644 index a55fbc83f..000000000 --- a/src/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/GF/Devel/Arch.hs b/src/GF/Devel/Arch.hs deleted file mode 100644 index dedb1b4f5..000000000 --- a/src/GF/Devel/Arch.hs +++ /dev/null @@ -1,89 +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.Devel.Arch ( - myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime, - welcomeArch, laterModTime) where - -import System.Time -import System.Random -import System.CPUTime -import Control.Monad (filterM) -import System.Directory - - ----- 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/GF/Devel/CheckGrammar.hs b/src/GF/Devel/CheckGrammar.hs deleted file mode 100644 index 0910802d1..000000000 --- a/src/GF/Devel/CheckGrammar.hs +++ /dev/null @@ -1,1090 +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.Devel.CheckGrammar ( - showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Refresh ---- - -import GF.Devel.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 -{- ---- should check that not fun type - 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 cannot be" 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 - - 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 - PChar -> True - PChars _ -> 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 - 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 :: 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 <- if n==0 then return val else - 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/GF/Devel/CheckM.hs b/src/GF/Devel/CheckM.hs deleted file mode 100644 index d26dbc07c..000000000 --- a/src/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/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs deleted file mode 100644 index 0655913e1..000000000 --- a/src/GF/Devel/Compile.hs +++ /dev/null @@ -1,203 +0,0 @@ -module GF.Devel.Compile (batchCompile) where - --- the main compiler passes -import GF.Devel.GetGrammar -import GF.Compile.Extend -import GF.Compile.Rebuild -import GF.Compile.Rename -import GF.Grammar.Refresh -import GF.Devel.CheckGrammar -import GF.Devel.Optimize ---import GF.Compile.Evaluate ---- -import GF.Devel.OptimizeGF ---import GF.Canon.Share ---import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.CompactPrint -import GF.Devel.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Devel.ReadFiles - -import GF.Source.GrammarToSource -import qualified GF.Source.AbsGF as A -import qualified GF.Source.PrintGF as P - -import GF.Data.Operations -import GF.Devel.UseIO -import GF.Devel.Arch - -import Control.Monad -import System.Directory -import System.FilePath -import System.Time -import qualified Data.Map as Map - -batchCompile :: Options -> [FilePath] -> IOE SourceGrammar -batchCompile opts files = do - (_,gr,_) <- foldM (compileModule defOpts) emptyCompileEnv files - return gr - where - defOpts = addOptions opts (options [emitCode]) - --- to output an intermediate stage -intermOut :: Options -> Option -> String -> IOE () -intermOut opts opt s = if oElem opt opts then - ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) - else return () - -prMod :: SourceModule -> String -prMod = compactPrint . prModule - - --- | the environment -type CompileEnv = (Int,SourceGrammar,ModEnv) - --- | 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,rfs) = env - 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 ---- - foldM (compileOne opts) (0,sgr,rfs) files - - -compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv -compileOne opts env@(_,srcgr,_) file = do - - let putp s = putPointE opts 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 m) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = modules srcgr - - case gf of - - -- for compiled gf, read the file and update environment - -- also undo common subexp optimization, to enable normal computations - ".gfo" -> do - sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 - - extendCompileEnv env file sm - - -- for gf source, do full compilation and generate code - _ -> do - - let gfo = gfoFile (dropExtension file) - b1 <- ioeIO $ doesFileExist file - if not b1 - then compileOne opts env $ gfo - else do - - sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm) <- compileSourceModule opts env sm0 - let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str - cm <- putpp " generating code... " $ generateModuleCode opts gfo sm1 - -- sm is optimized before generation, but not in the env - extendCompileEnvInt env k' gfo 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 - - let putp = putPointE opts - putpp = putPointEsil opts - mos = modules gr - - mo1 <- ioeErr $ rebuildModule mos mo - intermOut opts (iOpt "show_rebuild") (prMod mo1) - - mo1b <- ioeErr $ extendModule mos mo1 - intermOut opts (iOpt "show_extend") (prMod mo1b) - - case mo1b of - (_,ModMod n) | not (isCompleteModule n) -> do - return (k,mo1b) -- refresh would fail, since not renamed - _ -> do - mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - intermOut opts (iOpt "show_rename") (prMod mo2) - - (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 - if null warnings then return () else putp warnings $ return () - intermOut opts (iOpt "show_typecheck") (prMod mo3) - - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - intermOut opts (iOpt "show_refresh") (prMod mo3r) - - let eenv = () --- emptyEEnv - (mo4,eenv') <- - ---- if oElem "check_only" opts - putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r - return (k',mo4) - where - ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug - prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] - -generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule -generateModuleCode opts file minfo = do - let minfo1 = subexpModule minfo - out = prGrammar (MGrammar [minfo1]) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out - return minfo1 - 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,emptyMGrammar,Map.empty) - -extendCompileEnvInt (_,MGrammar ss,menv) k file sm = do - let (mod,imps) = importsOfModule (trModule sm) - t <- ioeIO $ getModificationTime file - return (k,MGrammar (sm:ss),Map.insert mod (t,imps) menv) --- reverse later - -extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k file sm - - diff --git a/src/GF/Devel/Compile/AbsGF.hs b/src/GF/Devel/Compile/AbsGF.hs deleted file mode 100644 index d053a3fa1..000000000 --- a/src/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/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs deleted file mode 100644 index 30ea0a70e..000000000 --- a/src/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/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs deleted file mode 100644 index 07e059ed4..000000000 --- a/src/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/GF/Devel/Compile/ErrM.hs b/src/GF/Devel/Compile/ErrM.hs deleted file mode 100644 index 9cad4e252..000000000 --- a/src/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/GF/Devel/Compile/Extend.hs b/src/GF/Devel/Compile/Extend.hs deleted file mode 100644 index 2f1aae65b..000000000 --- a/src/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/GF/Devel/Compile/Factorize.hs b/src/GF/Devel/Compile/Factorize.hs deleted file mode 100644 index 7386f3ed5..000000000 --- a/src/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/GF/Devel/Compile/GF.cf b/src/GF/Devel/Compile/GF.cf deleted file mode 100644 index 3edbdf347..000000000 --- a/src/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/GF/Devel/Compile/GFC.hs b/src/GF/Devel/Compile/GFC.hs deleted file mode 100644 index f60ec9380..000000000 --- a/src/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/GF/Devel/Compile/GFtoGFCC.hs b/src/GF/Devel/Compile/GFtoGFCC.hs deleted file mode 100644 index 81f33e11a..000000000 --- a/src/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/GF/Devel/Compile/GetGrammar.hs b/src/GF/Devel/Compile/GetGrammar.hs deleted file mode 100644 index b90bd912c..000000000 --- a/src/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/GF/Devel/Compile/LexGF.hs b/src/GF/Devel/Compile/LexGF.hs deleted file mode 100644 index ff8386f49..000000000 --- a/src/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/GF/Devel/Compile/Optimize.hs b/src/GF/Devel/Compile/Optimize.hs deleted file mode 100644 index 746b47b90..000000000 --- a/src/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/GF/Devel/Compile/ParGF.hs b/src/GF/Devel/Compile/ParGF.hs deleted file mode 100644 index ce474e418..000000000 --- a/src/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/GF/Devel/Compile/PrintGF.hs b/src/GF/Devel/Compile/PrintGF.hs deleted file mode 100644 index 7eb63612a..000000000 --- a/src/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/GF/Devel/Compile/Refresh.hs b/src/GF/Devel/Compile/Refresh.hs deleted file mode 100644 index 1708761fc..000000000 --- a/src/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/GF/Devel/Compile/Rename.hs b/src/GF/Devel/Compile/Rename.hs deleted file mode 100644 index 9ba704c19..000000000 --- a/src/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/GF/Devel/Compile/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs deleted file mode 100644 index a62179c18..000000000 --- a/src/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 (mkIdent "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/GF/Devel/Compute.hs b/src/GF/Devel/Compute.hs deleted file mode 100644 index a9081c28a..000000000 --- a/src/GF/Devel/Compute.hs +++ /dev/null @@ -1,455 +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.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 - - ps0 <- mapM (compPatternMacro . fst) cs - cs' <- mapM (compBranchOpt g) (zip ps0 (map snd 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 - - compPatternMacro p = case p of - PM m c -> case look m c of - Ok (EPatt p') -> compPatternMacro p' - _ -> prtBad "pattern expected as value of" p ---- should be in CheckGr - PAs x p -> do - p' <- compPatternMacro p - return $ PAs x p' - PAlt p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PAlt p' q' - PSeq p q -> do - p' <- compPatternMacro p - q' <- compPatternMacro q - return $ PSeq p' q' - PRep p -> do - p' <- compPatternMacro p - return $ PRep p' - PNeg p -> do - p' <- compPatternMacro p - return $ PNeg p' - PR rs -> do - rs' <- mapPairsM compPatternMacro rs - return $ PR rs' - - _ -> return p - - 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/GF/Devel/GF.hs b/src/GF/Devel/GF.hs deleted file mode 100644 index 70fddcd67..000000000 --- a/src/GF/Devel/GF.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import GF.Devel.GFC -import GF.Devel.GFI - -import System (getArgs) - -main :: IO () -main = do - xx <- getArgs - case xx of - "--batch":args -> mainGFC args - _ -> mainGFI xx - diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs deleted file mode 100644 index 27e0e3ae2..000000000 --- a/src/GF/Devel/GFC.hs +++ /dev/null @@ -1,67 +0,0 @@ -module GF.Devel.GFC (mainGFC) where --- module Main where - -import GF.Compile.API -import GF.Devel.PrintGFCC -import GF.GFCC.CId -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 - -import System.FilePath - -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 - gfcc <- appIOE (compileToGFCC opts fs) >>= err fail return - let gfccFile = targetNameGFCC opts (absname gfcc) - outputFile gfccFile (printGFCC gfcc) - mapM_ (alsoPrint opts gfcc) 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 gfccFile = targetNameGFCC opts (absname gfcc) - outputFile gfccFile (printGFCC gfcc) - mapM_ (alsoPrint opts gfcc) printOptions - - _ -> do - appIOE (mapM_ (batchCompile opts) (map return fs)) >>= err fail return - putStrLn "Done." - -targetName :: Options -> CId -> String -targetName opts abs = case getOptVal opts (aOpt "target") of - Just n -> n - _ -> prIdent abs - -targetNameGFCC :: Options -> CId -> FilePath -targetNameGFCC opts abs = targetName opts abs ++ ".gfcc" - ----- TODO: nicer and richer print options - -alsoPrint opts gr (opt,name) = do - if oElem (iOpt opt) opts - then outputFile name (prGFCC opt gr) - else return () - -outputFile :: FilePath -> String -> IO () -outputFile outfile output = - do writeFile outfile output - putStrLn $ "wrote file " ++ outfile - -printOptions = [ - ("haskell","GSyntax.hs"), - ("haskell_gadt","GSyntax.hs"), - ("js","grammar.js") - ] - -usageMsg = - "usage: gfc (-h | --make (-noopt) (-noparse) (-target=PREFIX) (-js | -haskell | -haskell_gadt)) (-src) FILES" diff --git a/src/GF/Devel/GFC/Main.hs b/src/GF/Devel/GFC/Main.hs deleted file mode 100644 index d9ceb8e70..000000000 --- a/src/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/GF/Devel/GFCCInterpreter.hs b/src/GF/Devel/GFCCInterpreter.hs deleted file mode 100644 index b2b17dba7..000000000 --- a/src/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/GF/Devel/GFCCtoHaskell.hs b/src/GF/Devel/GFCCtoHaskell.hs deleted file mode 100644 index aa3eebe58..000000000 --- a/src/GF/Devel/GFCCtoHaskell.hs +++ /dev/null @@ -1,213 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoHaskell --- 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.Devel.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where - -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId - -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List --(isPrefixOf, find, intersperse) -import qualified Data.Map as Map - --- | the main function -grammar2haskell :: GFCC -> String -grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $ - haskPreamble ++ [datatypes gr', gfinstances gr'] - where gr' = hSkeleton gr - -grammar2haskellGADT :: GFCC -> String -grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $ - ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ - haskPreamble ++ [datatypesGADT gr', gfinstances 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.GFCC.DataGFCC", - "import GF.GFCC.CId", - "----------------------------------------------------", - "-- automatic translation from GF to Haskell", - "----------------------------------------------------", - "", - "class Gf a where", - " gf :: a -> Exp", - " fg :: Exp -> a", - "", - predefInst "GString" "String" "DTr [] (AS s) []", - "", - predefInst "GInt" "Integer" "DTr [] (AI s) []", - "", - predefInst "GFloat" "Double" "DTr [] (AF s) []", - "", - "----------------------------------------------------", - "-- below this line machine-generated", - "----------------------------------------------------", - "" - ] - -predefInst gtyp typ patt = - "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ - "instance Gf" +++ gtyp +++ "where" ++++ - " gf (" ++ gtyp +++ "s) =" +++ patt ++++ - " fg t =" ++++ - " case t of" ++++ - " " +++ patt +++ " ->" +++ gtyp +++ "s" ++++ - " _ -> error (\"no" +++ gtyp +++ "\" ++ show t)" - -type OIdent = String - -type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] - -datatypes, gfinstances :: (String,HSkeleton) -> String -datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd -gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g - -hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String -gfInstance :: 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 ++ "_" - -gfInstance m crs = hInstance m crs ++++ fInstance m crs - -----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\n" ++ - unlines [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 = "DTr [] (AC (CId \"" ++ f ++ "\"))" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" - - -----fInstance m ("Cn",_) = "" --- -fInstance m (cat,[]) = "" -fInstance m (cat,rules) = - " fg t =" ++++ - " case t of" ++++ - unlines [mkInst f xx | (f,xx) <- rules] ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ show t)" - where - mkInst f xx = - " DTr [] (AC (CId \"" ++ 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] - - ---type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] -hSkeleton :: GFCC -> (String,HSkeleton) -hSkeleton gr = - (pr (absname gr), - [(pr c, [(pr f, map pr cs) | (f, (cs,_)) <- fs]) | - fs@((_, (_,c)):_) <- fns] - ) - where - fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) - valtyps (_, (_,x)) (_, (_,y)) = compare x y - valtypg (_, (_,x)) (_, (_,y)) = x == y - pr (CId c) = c - jty (f,(ty,_)) = (f,catSkeleton ty) - -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 - -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/GF/Devel/GFCCtoJS.hs b/src/GF/Devel/GFCCtoJS.hs deleted file mode 100644 index c61ad08d5..000000000 --- a/src/GF/Devel/GFCCtoJS.hs +++ /dev/null @@ -1,132 +0,0 @@ -module GF.Devel.GFCCtoJS (gfcc2js) where - -import qualified GF.GFCC.Macros as M -import qualified GF.GFCC.DataGFCC as D -import GF.GFCC.CId -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -import GF.Formalism.FCFG -import GF.Parsing.FCFG.PInfo -import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) - -import GF.Text.UTF8 -import GF.Data.ErrM -import GF.Infra.Option - -import Control.Monad (mplus) -import Data.Array (Array) -import qualified Data.Array as Array -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map - -gfcc2js :: D.GFCC -> String -gfcc2js gfcc = - encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] - where - n = D.printCId $ D.absname gfcc - as = D.abstract gfcc - cs = Map.assocs (D.concretes gfcc) - start = M.lookStartCat gfcc - grammar = new "GFGrammar" [abstract, concrete] - abstract = abstract2js start as - concrete = JS.EObj $ map (concrete2js start n) cs - -abstract2js :: String -> D.Abstr -> JS.Expr -abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))] - -absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property -absdef2js (CId f,(typ,_)) = - let (args,CId cat) = M.catSkeleton typ in - JS.Prop (JS.StringPropName f) (new "Type" [JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat]) - -concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property -concrete2js start n (CId c, cnc) = - JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n c) ds) ++ litslins))] ++ - maybe [] (parser2js start) (D.parser cnc))) - where - l = JS.StringPropName c - ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc] - litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), - JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), - JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] - - -cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property -cncdef2js n l (CId f, t) = JS.Prop (JS.StringPropName f) (JS.EFun [children] [JS.SReturn (term2js n l t)]) - -term2js :: String -> String -> D.Term -> JS.Expr -term2js n l t = f t - where - f t = - case t of - D.R xs -> new "Arr" (map f xs) - D.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] - D.S xs -> mkSeq (map f xs) - D.K t -> tokn2js t - D.V i -> JS.EIndex (JS.EVar children) (JS.EInt i) - D.C i -> new "Int" [JS.EInt i] - D.F (CId f) -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr f, JS.EVar children] - D.FV xs -> new "Variants" (map f xs) - D.W str x -> new "Suffix" [JS.EStr str, f x] - D.RP x y -> new "Rp" [f x, f y] - D.TM _ -> new "Meta" [] - -tokn2js :: D.Tokn -> JS.Expr -tokn2js (D.KS s) = mkStr s -tokn2js (D.KP ss vs) = mkSeq (map mkStr ss) -- FIXME - -mkStr :: String -> JS.Expr -mkStr s = new "Str" [JS.EStr s] - -mkSeq :: [JS.Expr] -> JS.Expr -mkSeq [x] = x -mkSeq xs = new "Seq" xs - -argIdent :: Integer -> JS.Ident -argIdent n = JS.Ident ("x" ++ show n) - -children :: JS.Ident -children = JS.Ident "cs" - --- Parser -parser2js :: String -> FCFPInfo -> [JS.Expr] -parser2js start p = [new "Parser" [JS.EStr start, - JS.EArray $ map frule2js (Array.elems (allRules p)), - JS.EObj $ map cats (Map.assocs (startupCats p))]] - where - cats (CId c,is) = JS.Prop (JS.StringPropName c) (JS.EArray (map JS.EInt is)) - -frule2js :: FRule -> JS.Expr -frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins] - -name2js :: FName -> JS.Expr -name2js n = case n of - Name (CId "_") [p] -> fromProfile p - Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] - where - fromProfile :: Profile (SyntaxForest CId) -> JS.Expr - fromProfile (Unify []) = new "MetaVar" [] - fromProfile (Unify [x]) = daughter x - fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)] - fromProfile (Constant forest) = fromSyntaxForest forest - - daughter i = new "Arg" [JS.EInt i] - - fromSyntaxForest :: SyntaxForest CId -> JS.Expr - fromSyntaxForest FMeta = new "MetaVar" [] - -- FIXME: is there always just one element here? - fromSyntaxForest (FNode n [args]) = new "FunApp" $ [JS.EStr $ prCId n, JS.EArray (map fromSyntaxForest args)] - fromSyntaxForest (FString s) = new "Lit" $ [JS.EStr s] - fromSyntaxForest (FInt i) = new "Lit" $ [JS.EInt $ fromIntegral i] - fromSyntaxForest (FFloat f) = new "Lit" $ [JS.EDbl f] - -lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr -lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] - -sym2js :: FSymbol -> JS.Expr -sym2js (FSymCat _ l n) = new "ArgProj" [JS.EInt n, JS.EInt l] -sym2js (FSymTok t) = new "Terminal" [JS.EStr t] - -new :: String -> [JS.Expr] -> JS.Expr -new f xs = JS.ENew (JS.Ident f) xs diff --git a/src/GF/Devel/GFI.hs b/src/GF/Devel/GFI.hs deleted file mode 100644 index f59bd15e6..000000000 --- a/src/GF/Devel/GFI.hs +++ /dev/null @@ -1,77 +0,0 @@ -module GF.Devel.GFI (mainGFI) where - -import GF.Command.Interpreter -import GF.Command.Importing -import GF.Command.Commands -import GF.GFCC.API - -import GF.Devel.UseIO -import GF.Devel.Arch -import GF.Infra.Option ---- Haskell's option lib - - -mainGFI :: [String] -> IO () -mainGFI xx = do - putStrLn welcome - env <- importInEnv emptyMultiGrammar xx - loop (GFEnv env [] 0) - return () - -loop :: GFEnv -> IO GFEnv -loop gfenv0 = do - let env = commandenv gfenv0 - putStrFlush (prompt env) - s <- getLine - let gfenv = gfenv0 {history = s : history gfenv0} - case words s of - - -- special commands, working on GFEnv - "i":args -> do - env1 <- importInEnv (multigrammar env) args - loopNewCPU $ gfenv {commandenv = env1} - "e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyMultiGrammar}} - "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv - "q":_ -> putStrLn "See you." >> return gfenv - - -- ordinary commands, working on CommandEnv - _ -> do - interpretCommandLine env s - loopNewCPU gfenv - -loopNewCPU gfenv = do - cpu <- prCPU $ cputime gfenv - loop $ gfenv {cputime = cpu} - -importInEnv mgr0 xx = do - let (opts,files) = getOptions "-" xx - mgr1 <- case files of - [] -> return mgr0 - _ -> importGrammar mgr0 opts files - let env = CommandEnv mgr1 (allCommands mgr1) - putStrLn $ unwords $ "\nLanguages:" : languages mgr1 - return env - -welcome = unlines [ - " ", - " * * * ", - " * * ", - " * * ", - " * ", - " * ", - " * * * * * * * ", - " * * * ", - " * * * * * * ", - " * * * ", - " * * * ", - " ", - "This is GF version 3.0 alpha. ", - "Some things may work. " - ] - -prompt env = abstractName (multigrammar env) ++ "> " - -data GFEnv = GFEnv { - commandenv :: CommandEnv, - history :: [String], - cputime :: Integer - } diff --git a/src/GF/Devel/GetGrammar.hs b/src/GF/Devel/GetGrammar.hs deleted file mode 100644 index cdd275ace..000000000 --- a/src/GF/Devel/GetGrammar.hs +++ /dev/null @@ -1,54 +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.GetGrammar where - -import GF.Data.Operations -import qualified GF.Source.ErrM as E - -import GF.Devel.UseIO -import GF.Grammar.Grammar -import GF.Infra.Modules -import GF.Devel.PrGrammar -import qualified GF.Source.AbsGF as A -import GF.Source.SourceToGrammar ----- import Macros ----- import Rename -import GF.Infra.Option ---- import Custom -import GF.Source.ParGF -import qualified GF.Source.LexGF as L - -import GF.Devel.ReadFiles ---- - -import Data.Char (toUpper) -import Data.List (nub) -import qualified Data.ByteString.Char8 as BS -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 $ pModDef tokens - ioeErr $ transModDef mo1 diff --git a/src/GF/Devel/Grammar/AppPredefined.hs b/src/GF/Devel/Grammar/AppPredefined.hs deleted file mode 100644 index c8d2988fd..000000000 --- a/src/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),(wildIdent,Vr (identC "P"))],typeStr,[]) - "toStr" -> return $ mkProds -- (L : Type) -> L -> Str - ([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[]) - "mapStr" -> - let ty = identC "L" in - return $ mkProds -- (L : Type) -> (Str -> Str) -> L -> L - ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,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/GF/Devel/Grammar/Compute.hs b/src/GF/Devel/Grammar/Compute.hs deleted file mode 100644 index 5e465c160..000000000 --- a/src/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/GF/Devel/Grammar/Construct.hs b/src/GF/Devel/Grammar/Construct.hs deleted file mode 100644 index 5b4215843..000000000 --- a/src/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/GF/Devel/Grammar/GFtoSource.hs b/src/GF/Devel/Grammar/GFtoSource.hs deleted file mode 100644 index 292f5b826..000000000 --- a/src/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/GF/Devel/Grammar/Grammar.hs b/src/GF/Devel/Grammar/Grammar.hs deleted file mode 100644 index df5a3907e..000000000 --- a/src/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/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs deleted file mode 100644 index 689996760..000000000 --- a/src/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/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs deleted file mode 100644 index 1a7a3582c..000000000 --- a/src/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 ([(wildIdent, 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 = (wildIdent, 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 wildIdent --- 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/GF/Devel/Grammar/PatternMatch.hs b/src/GF/Devel/Grammar/PatternMatch.hs deleted file mode 100644 index ec64d7802..000000000 --- a/src/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/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs deleted file mode 100644 index 221a0ac61..000000000 --- a/src/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 (wildIdent, 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/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs deleted file mode 100644 index 2c1bbc169..000000000 --- a/src/GF/Devel/GrammarToGFCC.hs +++ /dev/null @@ -1,545 +0,0 @@ -module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc,addParsers) where - -import GF.Devel.OptimizeGF (unshareModule) - -import GF.Grammar.Grammar -import qualified GF.Grammar.Lookup as Look - -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 qualified GF.Grammar.Abstract as A -import qualified GF.Grammar.Macros as GM ---import qualified GF.Grammar.Compute as Compute -import qualified GF.Infra.Modules as M -import qualified GF.Infra.Option as O - -import GF.Conversion.SimpleToFCFG (convertConcrete) -import GF.Parsing.FCFG.PInfo (buildFCFPInfo) -import GF.Devel.PrGrammar -import GF.Devel.PrintGFCC -import GF.Devel.ModDeps -import GF.Infra.Ident -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 ---- - --- when developing, swap commenting - ---traceD s t = trace s t -traceD s t = t - - --- the main function: generate GFCC from GF. - -prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String) -prGrammar2gfcc opts cnc gr = (abs,printGFCC gc) where - (abs,gc) = mkCanon2gfcc opts cnc gr - -mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC) -mkCanon2gfcc opts cnc gr = - (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr) - where - abs = err error id $ M.abstractOfConcrete gr (identC cnc) - pars = mkParamLincat gr - --- Adds parsers for all concretes -addParsers :: D.GFCC -> D.GFCC -addParsers gfcc = gfcc { D.concretes = Map.map conv (D.concretes gfcc) } - where - conv cnc = cnc { D.parser = Just (buildFCFPInfo (convertConcrete (D.abstract gfcc) cnc)) } - --- Generate GFCC from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.GFCC -canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = - (if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $ - D.GFCC an cns gflags abs cncs - where - -- 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) | Opt (f,[x]) <- M.flags abm] - mkDef pty = case pty of - Yes t -> mkExp t - _ -> CM.primNotion - - -- concretes - lfuns = [(f', (mkType ty, mkDef pty)) | - (f,AbsFun (Yes ty) pty) <- tree2list (M.jments abm), let f' = i2i f] - funs = Map.fromAscList lfuns - lcats = [(i2i c, mkContext cont) | - (c,AbsCat (Yes cont) _) <- tree2list (M.jments abm)] - cats = Map.fromAscList lcats - catfuns = Map.fromList - [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - - cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,M.ModMod mo) <- cms] - mkConcr lang0 lang mo = - (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) - where - js = tree2list (M.jments mo) - flags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags mo] - opers = Map.fromAscList [] -- opers will be created as optimization - utf = if elem (Opt ("coding",["utf8"])) (M.flags mo) - then D.convertStringsInTerm decodeUTF8 else id - lins = Map.fromAscList - [(i2i f, utf (mkTerm tr)) | (f,CncFun _ (Yes tr) _) <- js] - lincats = Map.fromAscList - [(i2i c, mkCType ty) | (c,CncCat (Yes ty) _ _) <- js] - lindefs = Map.fromAscList - [(i2i c, mkTerm tr) | (c,CncCat _ (Yes tr) _) <- js] - printnames = Map.union - (Map.fromAscList [(i2i f, mkTerm tr) | (f,CncFun _ _ (Yes tr)) <- js]) - (Map.fromAscList [(i2i f, mkTerm tr) | (f,CncCat _ _ (Yes tr)) <- js]) - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,CncCat (Yes ty) _ _) <- js] - fcfg = Nothing - -i2i :: Ident -> CId -i2i = CId . prIdent - -mkType :: A.Type -> C.Type -mkType t = case GM.typeForm t of - Ok (hyps,(_,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 - Ok (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 (MetaSymb 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 (IAV (_,_,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)) - TSh _ _ -> error $ show tr - 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 (A.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 - Strs 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 :: SourceGrammar -> 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 -> SourceGrammar -> SourceGrammar -reorder abs cg = M.MGrammar $ - (abs, M.ModMod $ - M.Module M.MTAbstract M.MSComplete aflags [] [] adefs): - [(c, M.ModMod $ - M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js)) - | (c,(fs,js)) <- cncs] - where - mos = M.allModMod cg - adefs = sorted2tree $ sortIds $ - predefADefs ++ Look.allOrigInfos cg abs - predefADefs = - [(IC c, AbsCat (Yes []) Nope) | c <- ["Float","Int","String"]] - aflags = nubFlags $ - concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] - - cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = (nubFlags flags, - sortIds (predefCDefs ++ jments)) where - jments = Look.allOrigInfos cg la - flags = concat [M.flags mo | - (i,mo) <- mos, M.isModCnc mo, - Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = - (IC "Int", CncCat (Yes Look.linTypeInt) Nope Nope) : - [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | - ---- lindef,printname - c <- ["Float","String"]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare f g) - nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g) - - --- one grammar per language - needed for symtab generation -repartition :: Ident -> SourceGrammar -> [SourceGrammar] -repartition abs cg = [M.partOfGrammar cg (lang,mo) | - let mos = M.allModMod cg, - lang <- M.allConcretes cg abs, - let mo = errVal - (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang - ] - - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Ident -> SourceGrammar -> SourceGrammar -canon2canon abs = - recollect . map cl2cl . repartition abs . purgeGrammar abs - where - recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules - - js2js ms = map (c2c (j2j (M.MGrammar ms))) ms - - c2c f2 (c,m) = case m of - M.ModMod mo@(M.Module _ _ _ _ _ js) -> - (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 js) - _ -> (c,m) - j2j cg (f,j) = case j of - CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z) - CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y) - _ -> (f,j) - where - t2t = term2term cg pv - ty2ty = type2type cg pv - pv@(labels,untyps,typs) = trs $ paramValues cg - - -- flatten record arguments of param constructors - p2p (f,j) = case j of - 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 = traceD (tr v) v - - tr (labels,untyps,typs) = - ("LABELS:" ++++ - unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | - ((c,l),i) <- Map.toList labels]) ++++ - ("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i | - (t,i) <- Map.toList untyps]) ++++ - ("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) | - (t,i) <- Map.toList typs]) ----- - -purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar -purgeGrammar abstr gr = - (M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr - where - list ms = traceD ("MODULES" +++ unwords (map (prt . fst) ms)) ms - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - needed = nub $ concatMap (requiredCanModules isSingle gr) acncs - acncs = abstr : M.allConcretes gr abstr - isSingle = True - complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon - 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 :: SourceGrammar -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - partyps = nub $ - --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt -{- - [ty | - (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments, - ty0 <- [ty | (_, ty) <- unlockTyp ls], - ty <- typsFrom ty0 --} - [ty | - (_,(_,CncCat (Yes ty0) _ _)) <- jments, - ty <- typsFrom ty0 - ] ++ [ - Q m ty | - (m,(ty,ResParam _)) <- jments - ] ++ [ty | - (_,(_,CncFun _ (Yes tr) _)) <- jments, - ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] - ] - params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ - Look.allParamValues cgr ty) | ty <- partyps] - typsFrom ty = unlockTy ty : case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> concat [typsFrom t | (_, t) <- ls] - _ -> [] - - 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 - - jments = - [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo] - 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 "Int",[f | let RecType fs = Look.linTypeInt, f <- fs])] ++ - [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Float", "String"]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,ls) | (_,(cat,CncCat (Yes ty) _ _)) <- jments, - RecType ls <- [unlockTy ty]] ----- [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls] - -- go to tables recursively - ---- TODO: even go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls)) - Table _ t -> getRec t - _ -> [] - -type2type :: SourceGrammar -> 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 :: SourceGrammar -> 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 (TWild _) _ -> error $ "wild" +++ prt tr - 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 tb (FV ts) -> FV $ map (comp . S tb) 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 $ "doVar1" +++ A.prt ty - _ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug - 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 ((A.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 (IAV (cat,_,_)) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated - ---- 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] -> 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 - RecType [] -> False - _ -> True - -unlockTyp = filter notlock - -notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - -unlockTy ty = case ty of - RecType ls -> RecType $ sort [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] - _ -> GM.composSafeOp unlockTy ty - - -prtTrace tr n = - trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n -prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n - - diff --git a/src/GF/Devel/Infra/ReadFiles.hs b/src/GF/Devel/Infra/ReadFiles.hs deleted file mode 100644 index dd8cbe5a9..000000000 --- a/src/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/GF/Devel/ModDeps.hs b/src/GF/Devel/ModDeps.hs deleted file mode 100644 index ec5702910..000000000 --- a/src/GF/Devel/ModDeps.hs +++ /dev/null @@ -1,153 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ModDeps --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Check correctness of module dependencies. Incomplete. --- --- AR 13\/5\/2003 ------------------------------------------------------------------------------ - -module GF.Devel.ModDeps (mkSourceGrammar, - moduleDeps, - openInterfaces, - requiredCanModules - ) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Devel.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules - -import GF.Data.Operations - -import Control.Monad -import Data.List - --- | to check uniqueness of module names and import names, the --- appropriateness of import and extend types, --- to build a dependency graph of modules, and to sort them topologically -mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar -mkSourceGrammar ms = do - let ns = map fst ms - checkUniqueErr ns - mapM (checkUniqueImportNames ns . snd) ms - deps <- moduleDeps ms - deplist <- either - return - (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ - topoTest deps - return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist] - -checkUniqueErr :: (Show i, Eq i) => [i] -> Err () -checkUniqueErr ms = do - let msg = checkUnique ms - if null msg then return () else Bad $ unlines msg - --- | check that import names don't clash with module names -checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () -checkUniqueImportNames ns mo = case mo of - ModMod m -> test [n | OQualif _ n v <- opens m, n /= v] - _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo - where - - test ms = testErr (all (`notElem` ns) ms) - ("import names clashing with module names among" +++ - unwords (map prt ms)) - -type Dependencies = [(IdentM Ident,[IdentM Ident])] - --- | to decide what modules immediately depend on what, and check if the --- dependencies are appropriate -moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies -moduleDeps ms = mapM deps ms where - deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of - ModMod m -> case mtype m of - MTConcrete a -> do - aty <- lookupModuleType gr a - testErr (aty == MTAbstract) "the of-module is not an abstract syntax" - chDep (IdentM c (MTConcrete a)) - (extends m) (MTConcrete a) (opens m) MTResource - t -> chDep (IdentM c t) (extends m) t (opens m) t - - chDep it es ety os oty = do - ests <- mapM (lookupModuleType gr) es - testErr (all (compatMType ety) ests) "inappropriate extension module type" ----- osts <- mapM (lookupModuleType gr . openedModule) os ----- testErr (all (compatOType oty) osts) "inappropriate open module type" - let ab = case it of - IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] - _ -> [] ---- - return (it, ab ++ - [IdentM e ety | e <- es] ++ - [IdentM (openedModule o) oty | o <- os]) - - -- check for superficial compatibility, not submodule relation etc: what can be extended - compatMType mt0 mt = case (mt0,mt) of - (MTResource, MTConcrete _) -> True - (MTInstance _, MTConcrete _) -> True - (MTInterface, MTAbstract) -> True - (MTConcrete _, MTConcrete _) -> True - (MTInstance _, MTInstance _) -> True - (MTReuse _, MTReuse _) -> True - (MTInstance _, MTResource) -> True - (MTResource, MTInstance _) -> True - ---- some more? - _ -> mt0 == mt - -- in the same way; this defines what can be opened - compatOType mt0 mt = case mt0 of - MTAbstract -> mt == MTAbstract - MTTransfer _ _ -> mt == MTAbstract - _ -> case mt of - MTResource -> True - MTReuse _ -> True - MTInterface -> True - MTInstance _ -> True - _ -> False - - gr = MGrammar ms --- hack - -openInterfaces :: Dependencies -> Ident -> Err [Ident] -openInterfaces ds m = do - let deps = [(i,ds) | (IdentM i _,ds) <- ds] - let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is] - let mods = iterFix (concatMap more) (more (m,undefined)) - return $ [i | (i,MTInterface) <- mods] - --- | this function finds out what modules are really needed in the canonical gr. --- its argument is typically a concrete module name -requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i] -requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where - exts = allExtends gr c - ops = if isSingle - then map fst (modules gr) - else iterFix (concatMap more) $ exts - more i = errVal [] $ do - m <- lookupModMod gr i - return $ extends m ++ [o | o <- map openedModule (opens m)] - notReuse i = errVal True $ do - m <- lookupModMod gr i - return $ isModRes m -- to exclude reused Cnc and Abs from required - - -{- --- to test -exampleDeps = [ - (ir "Nat",[ii "Gen", ir "Adj"]), - (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]), - (ir "Nou",[ii "Cas"]) - ] - -ii s = IdentM (IC s) MTInterface -ir s = IdentM (IC s) MTResource --} - diff --git a/src/GF/Devel/Optimize.hs b/src/GF/Devel/Optimize.hs deleted file mode 100644 index b44f6a53d..000000000 --- a/src/GF/Devel/Optimize.hs +++ /dev/null @@ -1,299 +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.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.Devel.Compute -import GF.Compile.BackOpt -import GF.Devel.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. - -type EEnv = () --- not used - --- 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 -> 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) - _ -> liftM (Abs strVar) $ mkDefField typ ----- _ -> 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/GF/Devel/OptimizeGF.hs b/src/GF/Devel/OptimizeGF.hs deleted file mode 100644 index 99e33941f..000000000 --- a/src/GF/Devel/OptimizeGF.hs +++ /dev/null @@ -1,271 +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.OptimizeGF ( - optModule,unshareModule,unsubexpModule,unoptModule,subexpModule,shareModule - ) where - -import GF.Grammar.Grammar -import GF.Grammar.Lookup -import GF.Infra.Ident -import qualified GF.Grammar.Macros as C -import GF.Grammar.PrGrammar (prt) -import qualified GF.Infra.Modules as M -import GF.Data.Operations - -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List - -optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) -optModule = subexpModule . shareModule - -shareModule = processModule optim - -unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -unoptModule gr = unshareModule gr . unsubexpModule - -unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -unshareModule gr = processModule (const (unoptim gr)) - -processModule :: - (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -processModule 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 (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m) -shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m) -shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t))) -shareInfo _ i = i - --- 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 (only true in GFC) --- - --- 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... in GFC would be safe - -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 :: SourceGrammar -> Term -> Term -unoptim gr = unfactor gr - -unfactor :: SourceGrammar -> 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 (mo,m) = errVal (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) - -unsubexpModule :: SourceModule -> SourceModule -unsubexpModule mo@(i,m) = case m of - M.ModMod (M.Module mt 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 xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)] - ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers - ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))] - _ -> [(c,info)] - unparTerm t = case t of - Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers - errVal t $ liftM unparTerm $ lookupResDef gr m 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 xs (Yes trm) pn -> do - trm' <- recomp f trm - return (f,CncFun xs (Yes trm') pn) - ResOper ty (Yes trm) -> do - trm' <- recomp f trm - return (f,ResOper ty (Yes trm')) - _ -> return (f,def) - recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> return $ Q mo (ident id) - _ -> C.composOp (recomp f) t - - list = Map.toList tree - - oper id trm = (ident id, ResOper (Yes (EInt 8)) (Yes trm)) - --- impossible type encoding generated opers - -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 xs (Yes trm) pn -> do - get trm - return $ fi - ResOper ty (Yes trm) -> do - get trm - return $ fi - _ -> 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/GF/Devel/Options.hs b/src/GF/Devel/Options.hs deleted file mode 100644 index 9a4087096..000000000 --- a/src/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/GF/Devel/PrGrammar.hs b/src/GF/Devel/PrGrammar.hs deleted file mode 100644 index 44d1c3200..000000000 --- a/src/GF/Devel/PrGrammar.hs +++ /dev/null @@ -1,233 +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 --- --- printing and prettyprinting class --- --- 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.PrGrammar where - -import GF.Data.Operations -import GF.Data.Zipper -import GF.Grammar.Grammar -import GF.Infra.Modules -import qualified GF.Source.PrintGF as P -import GF.Grammar.Values -import GF.Source.GrammarToSource ---- import GFC (CanonGrammar) --- cycle of modules - -import GF.Infra.Option -import GF.Infra.Ident -import GF.Data.Str - -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. - --- | to show terms etc in error messages -prtBad :: Print a => String -> a -> Err b -prtBad s a = Bad (s +++ prt a) - -prGrammar :: SourceGrammar -> String -prGrammar = P.printTree . trGrammar - -prModule :: (Ident, SourceModInfo) -> String -prModule = P.printTree . trModule - -instance Print Term where - prt = P.printTree . trt - prt_ = prExp - -instance Print Ident where - prt = P.printTree . 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/GF/Devel/PrintGFCC.hs b/src/GF/Devel/PrintGFCC.hs deleted file mode 100644 index c7e668884..000000000 --- a/src/GF/Devel/PrintGFCC.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Devel.PrintGFCC where - -import GF.GFCC.DataGFCC (GFCC) -import GF.GFCC.Raw.ConvertGFCC (fromGFCC) -import GF.GFCC.Raw.PrintGFCCRaw (printTree) -import GF.Devel.GFCCtoHaskell -import GF.Devel.GFCCtoJS -import GF.Text.UTF8 - --- top-level access to code generation - -prGFCC :: String -> GFCC -> String -prGFCC printer gr = case printer of - "haskell" -> grammar2haskell gr - "haskell_gadt" -> grammar2haskellGADT gr - "js" -> gfcc2js gr - _ -> printGFCC gr - -printGFCC :: GFCC -> String -printGFCC = encodeUTF8 . printTree . fromGFCC - diff --git a/src/GF/Devel/README-testgf3 b/src/GF/Devel/README-testgf3 deleted file mode 100644 index 0d1b6e80a..000000000 --- a/src/GF/Devel/README-testgf3 +++ /dev/null @@ -1,49 +0,0 @@ -GF3, the next version of GF -Aarne Ranta - - -Version 1: 20/2/2008 - -To compile: - - make testgf3 - -To run: - - testgf3 - -Options: - - -src -- read from source - -doemit -- emit gfn files - -More options (debugging flags): - - -show_gf -- show compiled source module after parsing - -show_extend -- ... after extension - -show_rename -- ... after renaming - -show_typecheck -- ... after type checking - -show_refreshing -- ... after refreshing variables - -show_optimize -- ... after partial evaluation - -show_factorize -- ... after factoring optimization - -show_all -- show all phases - - -1 -- stop after parsing - -2 -- ... extending - -3 -- ... renaming - -4 -- ... type checking - -5 -- ... refreshing - -==Compiler Phases== - -LexGF -ParGF -SourceToGF -Extend -Rename -CheckGrammar -Refresh -Optimize -Factorize -GFtoGFCC - diff --git a/src/GF/Devel/ReadFiles.hs b/src/GF/Devel/ReadFiles.hs deleted file mode 100644 index a10ee1991..000000000 --- a/src/GF/Devel/ReadFiles.hs +++ /dev/null @@ -1,196 +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.ReadFiles - ( getAllFiles,ModName,ModEnv,getOptionsFromFile,importsOfModule, - gfoFile,gfFile,isGFO ) where - -import GF.Infra.Option -import GF.Data.Operations -import GF.Devel.UseIO -import GF.Source.AbsGF hiding (FileName) -import GF.Source.LexGF -import GF.Source.ParGF - -import Control.Monad -import Data.Char -import Data.List -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map -import System -import System.Time -import System.Directory -import System.FilePath - -type ModName = String -type ModEnv = Map.Map ModName (ClockTime,[ModName]) - - --- | Returns a list of all files to be compiled in topological order i.e. --- the low level (leaf) modules are first. -getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] -getAllFiles opts ps env file = do - -- read module headers from all files recursively - ds <- liftM reverse $ get [] [] (justModuleName file) - if oElem beVerbose opts - then ioeIO $ putStrLn $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds] - else return () - return $ paths ds - where - -- construct list of paths to read - paths cs = [mk (p f) | (f,st,_,_,p) <- cs, mk <- mkFile st] - where - mkFile CSComp = [gfFile ] - mkFile CSRead = [gfoFile] - mkFile _ = [] - - -- | traverses the dependency graph and returns a topologicaly sorted - -- list of ModuleInfo. An error is raised if there is circular dependency - get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles - -> [ModuleInfo] -- ^ a list of already traversed modules - -> ModName -- ^ the current module - -> IOE [ModuleInfo] -- ^ the final - get trc ds name - | name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc - | (not . null) [n | (n,_,_,_,_) <- ds, name == n] --- file already read - = return ds - | otherwise = do - (name,st0,t0,imps,p) <- findModule name - ds <- foldM (get (name:trc)) ds imps - let (st,t) | (not . null) [f | (f,CSComp,_,_,_) <- ds, elem f imps] - = (CSComp,Nothing) - | otherwise = (st0,t0) - return ((name,st,t,imps,p):ds) - - -- searches for module in the search path and if it is found - -- returns 'ModuleInfo'. It fails if there is no such module - findModule :: ModName -> IOE ModuleInfo - findModule name = do - (file,gfTime,gfoTime) <- do - mb_gfFile <- ioeIO $ getFilePathMsg "" ps (gfFile name) - case mb_gfFile of - Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile - mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (replaceExtension gfFile "gfo")) - (\_->return Nothing) - return (gfFile, Just gfTime, mb_gfoTime) - Nothing -> do mb_gfoFile <- ioeIO $ getFilePathMsg "" ps (gfoFile name) - case mb_gfoFile of - Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile - return (gfoFile, Nothing, Just gfoTime) - Nothing -> ioeErr $ Bad ("File " ++ gfFile name ++ " does not exist.") - - - let mb_envmod = Map.lookup name env - (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime - - imps <- if st == CSEnv - then return (maybe [] snd mb_envmod) - else do s <- ioeIO $ BS.readFile file - (mname,imps) <- ioeErr ((liftM importsOfModule . pModHeader . myLexer) s) - ioeErr $ testErr (mname == name) - ("module name" +++ mname +++ "differs from file name" +++ name) - return imps - - return (name,st,t,imps,dropFileName file) - - -isGFO :: FilePath -> Bool -isGFO = (== ".gfo") . takeExtensions - -gfoFile :: FilePath -> FilePath -gfoFile f = addExtension f "gfo" - -gfFile :: FilePath -> FilePath -gfFile f = addExtension f "gf" - - --- From the given Options and the time stamps computes --- whether the module have to be computed, read from .gfo or --- the environment version have to be used -selectFormat :: Options -> Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> (CompStatus,Maybe ClockTime) -selectFormat opts mtenv mtgf mtgfo = - case (mtenv,mtgfo,mtgf) of - (_,_,Just tgf) | fromSrc -> (CSComp,Nothing) - (Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) - (_,Just tgfo,_) | fromComp -> (CSRead,Just tgfo) - (Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv) - (_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo) - (Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist - (_,_, Nothing) -> (CSRead,Nothing) -- source does not exist - _ -> (CSComp,Nothing) - where - fromComp = oElem isCompiled opts -- i -gfo - fromSrc = oElem fromSource opts - - --- internal module dep information - - -data CompStatus = - CSComp -- compile: read gf - | CSRead -- read gfo - | CSEnv -- gfo is in env - deriving Eq - -type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath) - - -importsOfModule :: ModDef -> (ModName,[ModName]) -importsOfModule (MModule _ typ body) = modType typ (modBody body []) - where - modType (MTAbstract m) xs = (modName m,xs) - modType (MTResource m) xs = (modName m,xs) - modType (MTInterface m) xs = (modName m,xs) - modType (MTConcrete m m2) xs = (modName m,modName m2:xs) - modType (MTInstance m m2) xs = (modName m,modName m2:xs) - modType (MTTransfer m o1 o2) xs = (modName m,open o1 (open o2 xs)) - - modBody (MBody e o _) xs = extend e (opens o xs) - modBody (MNoBody is) xs = foldr include xs is - modBody (MWith i os) xs = include i (foldr open xs os) - modBody (MWithBody i os o _) xs = include i (foldr open (opens o xs) os) - modBody (MWithE is i os) xs = foldr include (include i (foldr open xs os)) is - modBody (MWithEBody is i os o _) xs = foldr include (include i (foldr open (opens o xs) os)) is - modBody (MReuse m) xs = modName m:xs - modBody (MUnion is) xs = foldr include xs is - - include (IAll m) xs = modName m:xs - include (ISome m _) xs = modName m:xs - include (IMinus m _) xs = modName m:xs - - open (OName n) xs = modName n:xs - open (OQualQO _ n) xs = modName n:xs - open (OQual _ _ n) xs = modName n:xs - - extend NoExt xs = xs - extend (Ext is) xs = foldr include xs is - - opens NoOpens xs = xs - opens (OpenIn os) xs = foldr open xs os - - modName (PIdent (_,s)) = s - - --- | 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 (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s - return $ fst $ getOptions "-" $ map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls diff --git a/src/GF/Devel/TC.hs b/src/GF/Devel/TC.hs deleted file mode 100644 index 5c439f671..000000000 --- a/src/GF/Devel/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.Devel.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkEqs, - eqVal, - whnf - ) where - -import GF.Data.Operations -import GF.Grammar.Abstract -import GF.Devel.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/GF/Devel/TestGF3.hs b/src/GF/Devel/TestGF3.hs deleted file mode 100644 index da4b5c8f6..000000000 --- a/src/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/GF/Devel/TypeCheck.hs b/src/GF/Devel/TypeCheck.hs deleted file mode 100644 index 818b48a10..000000000 --- a/src/GF/Devel/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.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 --- - -import GF.Devel.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/GF/Devel/UseIO.hs b/src/GF/Devel/UseIO.hs deleted file mode 100644 index afbf00efd..000000000 --- a/src/GF/Devel/UseIO.hs +++ /dev/null @@ -1,298 +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.Devel.UseIO where - -import GF.Data.Operations -import GF.Infra.Option -import GF.Today (libdir) - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error -import System.Environment -import System.CPUTime -import Control.Monad -import Control.Exception(evaluate) -import qualified Data.ByteString.Char8 as BS - -#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 - -readFileIf f = catch (readFile f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return "" - -readFileIfStrict f = catch (BS.readFile f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return BS.empty - -type FileName = String -type InitPath = String -type FullPath = String - -getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) -getFilePath ps file = 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 not exist - then get ps - else do pfile <- canonicalizePath pfile - return (Just pfile) - -readFileIfPath :: [FilePath] -> String -> IOE (FilePath,BS.ByteString) -readFileIfPath paths file = do - mpfile <- ioeIO $ getFilePath paths file - case mpfile of - Just pfile -> do - s <- ioeIO $ BS.readFile 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" -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 - - t1 <- ioeIO $ getCPUTime - a <- act >>= ioeIO . evaluate - t2 <- ioeIO $ getCPUTime - - ve $ ioeIO $ putStrLnFlush (' ' : show ((t2 - t1) `div` 1000000000) ++ " msec") - 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 BS.ByteString -readFileIOE f = ioe $ catch (BS.readFile 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, BS.ByteString) -readFileLibraryIOE ini f = ioe $ do - lp <- getLibraryPath - tryRead ini $ \_ -> - tryRead lp $ \e -> - return (Bad (show e)) - where - tryRead path onError = - catch (BS.readFile 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/GF/Devel/gf-code.txt b/src/GF/Devel/gf-code.txt deleted file mode 100644 index e8954bedf..000000000 --- a/src/GF/Devel/gf-code.txt +++ /dev/null @@ -1,66 +0,0 @@ -Guide to GF Implementation Code -Aarne Ranta - - - -This document describes the code in GF grammar compiler and interactive -environment. It is aimed to cover well the implementation of the forthcoming -GF3. In comparison to GF 2.8, this implementation uses -- the same source language, GF (only slightly modified) -- a different run-time target language, GFCC (instead of GFCM) -- a different separate compilation target language (a fragment GF itself, - instead of GFC) -- a different internal representation of source code - - -Apart from GFCC, the goal of GF3 is simplification and consolidation, rather -than innovation. This is shown in particular in the abolition of GFC, and in -the streamlined internal source code format. The insight needed to achieve -these simplifications would not have been possible (at least for us) without -years of experimenting with the more messy formats; those formats moreover -grew organically when features were added to the GF language, and the old -implementation was thus a result of evolution rather than careful planning. - -GF3 is planned to be released in an Alpha version in the end of 2007, its -sources forming a part of GF release 2.9. - -There are currently two versions of GF3, as regards executables and ``make`` -items: -- ``gf3``, using the old internal representation of source language, and - integrating a compiler from GF to GFCC and an interpreter of GFCC -- ``testgf3``, using the new formats everywhere but implementing the compiler - only; this program does not yet yield reasonable output - - -The descriptions below will target the newest ideas, that is, ``textgf3`` -whenever it differs from ``gf3``. - - -==The structure of the code== - -Code that is not shared with GF 2.8 is located in subdirectories of -``GF/Devel/``. Those subdirectories will, however, be moved one level -up. Currently they include -- ``GF/Devel/Grammar``: the datatypes and basic operations of source code -- ``GF/Devel/Compile``: the phases of compiling GF to GFCC - - -The other directories involved are -- ``GF/GFCC``: data types and functionalities of GFCC -- ``GF/Infra``: infrastructure utilities for the implementation -- ``GF/Data``: datastructures belonging to infrastructure - - -==The source code implementation== - -==The compiler== - -==The GFCC interpreter== - -==The GF command interpreter== - - - - - - diff --git a/src/GF/Devel/gf3.txt b/src/GF/Devel/gf3.txt deleted file mode 100644 index 56feeba2a..000000000 --- a/src/GF/Devel/gf3.txt +++ /dev/null @@ -1,84 +0,0 @@ -GF Version 3.0 -Aarne Ranta -7 November 2007 - - -This document summarizes the goals and status of the forthcoming -GF version 3.0. - -==Overview== - -GF 3 results from the following needs: -- refactor GF to make it more maintainable -- provide a simple command-line batch compiler -- replace gfc by the much simpler gfcc format for embedded grammars - - -The current implementation of GF 3 has three binaries: -- gfc, batch compiler, for building grammar applications -- gfi, interpreter for gfcc grammars, for using grammars -- gf, interactive compiler with interpreter, for developing grammars - - -Thus, roughly, gf = gfc + gfi. - -Question: should we have, like current GF, just one binary, gf, and -implement the others by shell scripts calling gf with suitable options? -- +: one binary is less code altogether -- +: one binary is easier to distribute and update -- -: each of the components is less code by itself -- -: many users might only need either the compiler or the interpreter -- -: those users could avoid installation problems such as readline - - -There are some analogies in other languages: - - || GF | Haskell | Java || - | gfc | ghc | javac | - | gfi | ghci* | java | - | gf | ghci* | - | - -In Haskell, ghci makes more than gfi since it reads source files, but -less than gf since it does not compile them to externally usable target -code. - - - - -==Status of code and functionalities== - -GF executable v. 2.8 -- gf: 263 modules, executable 7+ MB (on MacOS i386) - - -Current status of GF 3.0 alpha: -- gf3: 94 modules, executable 4+ MB -- gfc: 71 modules, executable 3+ MB -- gfi: 35 modules, executable 1+ MB - - -Missing functionalities -- in gfc: - - input formats: cf, ebnf, gfe, old gf - - output formats: speech grammars, bnfc - - integrating options for input, output, and debugging information - (as described in Devel/GFC/Options.hs) - - -- in gfi: - - command cc (computing with resource) - - morphological analysis, linearization with tables - - quizzes, treebanks - - syntax editor - - readline - - -==Additional feature options== - -Native Haskell readline - -Binary formats for gfo and gfcc - -Parallel compilation on multicore machines - - diff --git a/src/GF/Embed/EmbedAPI.hs b/src/GF/Embed/EmbedAPI.hs deleted file mode 100644 index 43e4f2546..000000000 --- a/src/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/GF/Embed/EmbedCustom.hs b/src/GF/Embed/EmbedCustom.hs deleted file mode 100644 index f315441c5..000000000 --- a/src/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/GF/Embed/EmbedParsing.hs b/src/GF/Embed/EmbedParsing.hs deleted file mode 100644 index 43909f355..000000000 --- a/src/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/GF/Embed/TemplateApp.hs b/src/GF/Embed/TemplateApp.hs deleted file mode 100644 index f8722691f..000000000 --- a/src/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/GF/Formalism/CFG.hs b/src/GF/Formalism/CFG.hs deleted file mode 100644 index c38adb4e2..000000000 --- a/src/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/GF/Formalism/FCFG.hs b/src/GF/Formalism/FCFG.hs deleted file mode 100644 index 5f9656658..000000000 --- a/src/GF/Formalism/FCFG.hs +++ /dev/null @@ -1,106 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Definitions of fast multiple context-free grammars ------------------------------------------------------------------------------ - -module GF.Formalism.FCFG - ( - -- * Token - FToken - - -- * Category - , FPath - , FCat - - , fcatString, fcatInt, fcatFloat, fcatVar - - -- * Symbol - , FIndex - , FSymbol(..) - - -- * Name - , FName - , isCoercionF - - -- * Grammar - , FPointPos - , FGrammar - , FRule(..) - ) where - -import Control.Monad (liftM) -import Data.List (groupBy) -import Data.Array -import qualified Data.Map as Map - -import GF.Formalism.Utilities -import qualified GF.GFCC.CId as AbsGFCC -import GF.Infra.PrintClass - - ------------------------------------------------------------- --- Token -type FToken = String - - ------------------------------------------------------------- --- Category -type FPath = [FIndex] -type FCat = Int - -fcatString, fcatInt, fcatFloat, fcatVar :: Int -fcatString = (-1) -fcatInt = (-2) -fcatFloat = (-3) -fcatVar = (-4) - - ------------------------------------------------------------- --- Symbol -type FIndex = Int -data FSymbol - = FSymCat {-# UNPACK #-} !FCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int - | FSymTok FToken - - ------------------------------------------------------------- --- Name -type FName = NameProfile AbsGFCC.CId - -isCoercionF :: FName -> Bool -isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_" -isCoercionF _ = False - - ------------------------------------------------------------- --- Grammar - -type FPointPos = Int -type FGrammar = ([FRule], Map.Map AbsGFCC.CId [FCat]) -data FRule = FRule FName [FCat] FCat (Array FIndex (Array FPointPos FSymbol)) - ------------------------------------------------------------- --- pretty-printing - -instance Print AbsGFCC.CId where - prt (AbsGFCC.CId s) = s - -instance Print FSymbol where - prt (FSymCat c l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")" - prt (FSymTok t) = simpleShow (prt t) - where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\"" - mkEsc '\\' = "\\\\" - mkEsc '\"' = "\\\"" - mkEsc '\n' = "\\n" - mkEsc '\t' = "\\t" - mkEsc chr = [chr] - prtList = prtSep " " - -instance Print FRule where - prt (FRule name args res lins) = prt name ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++ - " =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]" - prtList = prtSep "\n" diff --git a/src/GF/Formalism/GCFG.hs b/src/GF/Formalism/GCFG.hs deleted file mode 100644 index 5242081c7..000000000 --- a/src/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/GF/Formalism/MCFG.hs b/src/GF/Formalism/MCFG.hs deleted file mode 100644 index e6aa965e7..000000000 --- a/src/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/GF/Formalism/SimpleGFC.hs b/src/GF/Formalism/SimpleGFC.hs deleted file mode 100644 index ea1f9dc12..000000000 --- a/src/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.wildIdent - ----------------------------------------------------------------------- --- * 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/GF/Formalism/Utilities.hs b/src/GF/Formalism/Utilities.hs deleted file mode 100644 index d1826d095..000000000 --- a/src/GF/Formalism/Utilities.hs +++ /dev/null @@ -1,423 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/13 12:40:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.6 $ --- --- Basic type declarations and functions for grammar formalisms ------------------------------------------------------------------------------ - - -module GF.Formalism.Utilities where - -import Control.Monad -import Data.Array -import Data.List (groupBy) - -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Data.Utilities (sameLength, foldMerge, splitBy) - -import GF.Infra.PrintClass - ------------------------------------------------------------- --- * symbols - -data Symbol c t = Cat c | Tok t - deriving (Eq, Ord, Show) - -symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a -symbol fc ft (Cat cat) = fc cat -symbol fc ft (Tok tok) = ft tok - -mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u -mapSymbol fc ft = symbol (Cat . fc) (Tok . ft) - -filterCats :: [Symbol c t] -> [c] -filterCats syms = [ cat | Cat cat <- syms ] - -filterToks :: [Symbol c t] -> [t] -filterToks syms = [ tok | Tok tok <- syms ] - ------------------------------------------------------------- --- * 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) - - ------------------------------------------------------------- --- * representaions of input tokens - -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 - -instance Show t => Show (Input t) where - show input = "makeInput " ++ show (inputEdges input) - ----------- - -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 ] - - ------------------------------------------------------------- --- * representations of syntactical analyses - --- ** charts as finite maps over edges - --- | The values of the chart, a list of key-daughters pairs, --- has unique keys. In essence, it is a map from 'n' to daughters. --- The daughters should be a set (not necessarily sorted) of rhs's. -type SyntaxChart n e = Assoc e [SyntaxNode n [e]] - -data SyntaxNode n e = SMeta - | SNode n [e] - | SString String - | SInt Integer - | SFloat Double - deriving (Eq,Ord) - -groupSyntaxNodes :: Ord n => [SyntaxNode n e] -> [SyntaxNode n [e]] -groupSyntaxNodes [] = [] -groupSyntaxNodes (SNode n0 es0:xs) = (SNode n0 (es0:ess)) : groupSyntaxNodes xs' - where - (ess,xs') = span xs - - span [] = ([],[]) - span xs@(SNode n es:xs') - | n0 == n = let (ess,xs) = span xs' in (es:ess,xs) - | otherwise = ([],xs) -groupSyntaxNodes (SString s:xs) = (SString s) : groupSyntaxNodes xs -groupSyntaxNodes (SInt n:xs) = (SInt n) : groupSyntaxNodes xs -groupSyntaxNodes (SFloat f:xs) = (SFloat f) : groupSyntaxNodes xs - --- better(?) representation of forests: --- data Forest n = F (SMap n (SList [Forest n])) Bool --- == --- type Forest n = GeneralTrie n (SList [Forest n]) Bool --- (the Bool == isMeta) - --- ** syntax forests - -data SyntaxForest n = FMeta - | FNode n [[SyntaxForest n]] - -- ^ The outer list should be a set (not necessarily sorted) - -- of possible alternatives. Ie. the outer list - -- is a disjunctive node, and the inner lists - -- are (conjunctive) concatenative nodes - | FString String - | FInt Integer - | FFloat Double - deriving (Eq, Ord, Show) - -instance Functor SyntaxForest where - fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests - fmap _ (FString s) = FString s - fmap _ (FInt n) = FInt n - fmap _ (FFloat f) = FFloat f - fmap _ (FMeta) = FMeta - -forestName :: SyntaxForest n -> Maybe n -forestName (FNode n _) = Just n -forestName _ = Nothing - -unifyManyForests :: (Monad m, Eq n) => [SyntaxForest n] -> m (SyntaxForest n) -unifyManyForests = foldM unifyForests FMeta - --- | two forests can be unified, if either is 'FMeta', or both have the same parent, --- and all children can be unified -unifyForests :: (Monad m, Eq n) => SyntaxForest n -> SyntaxForest n -> m (SyntaxForest n) -unifyForests FMeta forest = return forest -unifyForests forest FMeta = return forest -unifyForests (FNode name1 children1) (FNode name2 children2) - | name1 == name2 && not (null children) = return $ FNode name1 children - where children = [ forests | forests1 <- children1, forests2 <- children2, - sameLength forests1 forests2, - forests <- zipWithM unifyForests forests1 forests2 ] -unifyForests (FString s1) (FString s2) - | s1 == s2 = return $ FString s1 -unifyForests (FInt n1) (FInt n2) - | n1 == n2 = return $ FInt n1 -unifyForests (FFloat f1) (FFloat f2) - | f1 == f2 = return $ FFloat f1 -unifyForests _ _ = fail "forest unification failure" - -{- måste tänka mer på detta: -compactForests :: Ord n => [SyntaxForest n] -> SList (SyntaxForest n) -compactForests = map joinForests . groupBy eqNames . sortForests - where eqNames f g = forestName f == forestName g - sortForests = foldMerge mergeForests [] . map return - mergeForests [] gs = gs - mergeForests fs [] = fs - mergeForests fs@(f:fs') gs@(g:gs') - = case forestName f `compare` forestName g of - LT -> f : mergeForests fs' gs - GT -> g : mergeForests fs gs' - EQ -> f : g : mergeForests fs' gs' - joinForests fs = case forestName (head fs) of - Nothing -> FMeta - Just name -> FNode name $ - compactDaughters $ - concat [ fss | FNode _ fss <- fs ] - compactDaughters fss = case head fss of - [] -> [[]] - [_] -> map return $ compactForests $ concat fss - _ -> nubsort fss --} - --- ** syntax trees - -data SyntaxTree n = TMeta - | TNode n [SyntaxTree n] - | TString String - | TInt Integer - | TFloat Double - deriving (Eq, Ord, Show) - -instance Functor SyntaxTree where - fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees - fmap _ (TString s) = TString s - fmap _ (TInt n) = TInt n - fmap _ (TFloat f) = TFloat f - fmap _ (TMeta) = TMeta - -treeName :: SyntaxTree n -> Maybe n -treeName (TNode n _) = Just n -treeName (TMeta) = Nothing - -unifyManyTrees :: (Monad m, Eq n) => [SyntaxTree n] -> m (SyntaxTree n) -unifyManyTrees = foldM unifyTrees TMeta - --- | two trees can be unified, if either is 'TMeta', --- or both have the same parent, and their children can be unified -unifyTrees :: (Monad m, Eq n) => SyntaxTree n -> SyntaxTree n -> m (SyntaxTree n) -unifyTrees TMeta tree = return tree -unifyTrees tree TMeta = return tree -unifyTrees (TNode name1 children1) (TNode name2 children2) - | name1 == name2 && sameLength children1 children2 - = liftM (TNode name1) $ zipWithM unifyTrees children1 children2 -unifyTrees (TString s1) (TString s2) - | s1 == s2 = return (TString s1) -unifyTrees (TInt n1) (TInt n2) - | n1 == n2 = return (TInt n1) -unifyTrees (TFloat f1) (TFloat f2) - | f1 == f2 = return (TFloat f1) -unifyTrees _ _ = fail "tree unification failure" - --- ** conversions between representations - -chart2forests :: (Ord n, Ord e) => - SyntaxChart n e -- ^ The complete chart - -> (e -> Bool) -- ^ When is an edge 'FMeta'? - -> [e] -- ^ The starting edges - -> SList (SyntaxForest n) -- ^ The result has unique keys, ie. all 'n' are joined together. - -- In essence, the result is a map from 'n' to forest daughters - --- simplest implementation - -chart2forests chart isMeta = concatMap (edge2forests []) - where edge2forests edges edge - | isMeta edge = [FMeta] - | edge `elem` edges = [] - | otherwise = map (item2forest (edge:edges)) $ chart ? edge - item2forest edges (SMeta) = FMeta - item2forest edges (SNode name children) = - FNode name $ children >>= mapM (edge2forests edges) - item2forest edges (SString s) = FString s - item2forest edges (SInt n) = FInt n - item2forest edges (SFloat f) = FFloat f - -{- -before AR inserted peb's patch 8/7/2007, this was: - -chart2forests chart isMeta = concatMap edge2forests - where edge2forests edge = if isMeta edge then [FMeta] - else map item2forest $ chart ? edge - item2forest (SMeta) = FMeta - item2forest (SNode name children) = FNode name $ children >>= mapM edge2forests - item2forest (SString s) = FString s - item2forest (SInt n) = FInt n - item2forest (SFloat f) = FFloat f - --} - -{- --- more intelligent(?) implementation, --- requiring that charts and forests are sorted maps and sorted sets -chart2forests chart isMeta = es2fs - where e2fs e = if isMeta e then [FMeta] else map i2f $ chart ? e - es2fs es = if null metas then fs else FMeta : fs - where (metas, nonMetas) = splitBy isMeta es - fs = map i2f $ unionMap (<++>) $ map (chart ?) nonMetas - i2f (name, children) = FNode name $ - case head children of - [] -> [[]] - [_] -> map return $ es2fs $ concat children - _ -> children >>= mapM e2fs --} - - -forest2trees :: SyntaxForest n -> SList (SyntaxTree n) -forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees -forest2trees (FString s) = [TString s] -forest2trees (FInt n) = [TInt n] -forest2trees (FFloat f) = [TFloat f] -forest2trees (FMeta) = [TMeta] - ----------------------------------------------------------------------- --- * profiles - --- | Pairing a rule name with a profile -data NameProfile a = Name a [Profile (SyntaxForest a)] - deriving (Eq, Ord, Show) - -name2fun :: NameProfile a -> a -name2fun (Name fun _) = fun - --- | A profile is a simple representation of a function on a number of arguments. --- We only use lists of profiles -data Profile a = Unify [Int] -- ^ The Int's are the argument positions. - -- 'Unify []' will become a metavariable, - -- 'Unify [a,b]' means that the arguments are equal, - | Constant a - deriving (Eq, Ord, Show) - -instance Functor Profile where - fmap f (Constant a) = Constant (f a) - fmap f (Unify xs) = Unify xs - --- | a function name where the profile does not contain arguments --- (i.e. denoting a constant, not a function) -constantNameToForest :: NameProfile a -> SyntaxForest a -constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile] - where unConstant (Constant a) = a - unConstant (Unify []) = FMeta - unConstant _ = error $ "constantNameToForest: the profile should not contain arguments" - --- | profile application; we need some way of unifying a list of arguments -applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a] -applyProfile unify profile args = map apply profile - where apply (Unify xs) = unify $ map (args !!) xs - apply (Constant a) = a - --- | monadic profile application -applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a] -applyProfileM unify profile args = mapM apply profile - where apply (Unify xs) = unify $ map (args !!) xs - apply (Constant a) = return a - --- | profile composition: --- --- > applyProfile u z (ps `composeProfiles` qs) args --- > == --- > applyProfile u z ps (applyProfile u z qs args) --- --- compare with function composition --- --- > (p . q) arg --- > == --- > p (q arg) --- --- Note that composing an 'Constant' with two or more arguments returns an error --- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need. -composeProfiles :: [Profile a] -> [Profile a] -> [Profile a] -composeProfiles ps qs = map compose ps - where compose (Unify [x]) = qs !! x - compose (Unify xs) = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ] - compose constant = constant - - - ------------------------------------------------------------- --- pretty-printing - -instance (Print c, Print t) => Print (Symbol c t) where - prt = symbol prt (simpleShow . prt) - where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\"" - mkEsc '\\' = "\\\\" - mkEsc '\"' = "\\\"" - mkEsc '\n' = "\\n" - mkEsc '\t' = "\\t" - mkEsc chr = [chr] - prtList = prtSep " " - -instance Print t => Print (Input t) where - prt input = "input " ++ prt (inputEdges input) - -instance (Print s) => Print (Edge s) where - prt (Edge i j s) = "[" ++ show i ++ "-" ++ show j ++ ": " ++ prt s ++ "]" - prtList = prtSep "" - -instance (Print s) => Print (SyntaxTree s) where - prt (TNode s trees) - | null trees = prt s - | otherwise = "(" ++ prt s ++ prtBefore " " trees ++ ")" - prt (TString s) = show s - prt (TInt n) = show n - prt (TFloat f) = show f - prt (TMeta) = "?" - prtList = prtAfter "\n" - -instance (Print s) => Print (SyntaxForest s) where - prt (FNode s []) = "(" ++ prt s ++ " - ERROR: null forests)" - prt (FNode s [[]]) = prt s - prt (FNode s [forests]) = "(" ++ prt s ++ prtBefore " " forests ++ ")" - prt (FNode s children) = "{" ++ prtSep " | " [ prt s ++ prtBefore " " forests | - forests <- children ] ++ "}" - prt (FString s) = show s - prt (FInt n) = show n - prt (FFloat f) = show f - prt (FMeta) = "?" - prtList = prtAfter "\n" - -instance Print a => Print (Profile a) where - prt (Unify []) = "?" - prt (Unify args) = prtSep "=" args - prt (Constant a) = prt a - -instance Print a => Print (NameProfile a) where - prt (Name fun profile) = prt fun ++ prt profile - - diff --git a/src/GF/Fudgets/ArchEdit.hs b/src/GF/Fudgets/ArchEdit.hs deleted file mode 100644 index 5bc0dc84b..000000000 --- a/src/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/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs deleted file mode 100644 index 15af12215..000000000 --- a/src/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/GF/Fudgets/EventF.hs b/src/GF/Fudgets/EventF.hs deleted file mode 100644 index 7ea058dfa..000000000 --- a/src/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/GF/Fudgets/FudgetOps.hs b/src/GF/Fudgets/FudgetOps.hs deleted file mode 100644 index 4aba5eec5..000000000 --- a/src/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/GF/Fudgets/UnicodeF.hs b/src/GF/Fudgets/UnicodeF.hs deleted file mode 100644 index 024205698..000000000 --- a/src/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/GF/GFCC/API.hs b/src/GF/GFCC/API.hs deleted file mode 100644 index c266a5553..000000000 --- a/src/GF/GFCC/API.hs +++ /dev/null @@ -1,140 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCAPI --- 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 19/9/2007 ------------------------------------------------------------------------------ - -module GF.GFCC.API where - -import GF.GFCC.Linearize -import GF.GFCC.Generate -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId -import GF.GFCC.Raw.ConvertGFCC -import GF.GFCC.Raw.ParGFCCRaw -import GF.Command.PPrTree - -import GF.Data.ErrM - -import GF.Parsing.FCFG - ---import GF.Data.Operations ---import GF.Infra.UseIO -import qualified Data.Map as Map -import System.Random (newStdGen) -import System.Directory (doesFileExist) - - --- This API is meant to be used when embedding GF grammars in Haskell --- programs. The embedded system is supposed to use the --- .gfcc grammar format, which is first produced by the gf program. - ---------------------------------------------------- --- Interface ---------------------------------------------------- - -data MultiGrammar = MultiGrammar {gfcc :: GFCC} -type Language = String -type Category = String -type Tree = Exp - -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])] - -generateAll :: MultiGrammar -> Category -> [Tree] -generateRandom :: MultiGrammar -> Category -> IO [Tree] -generateAllDepth :: MultiGrammar -> Category -> Maybe Int -> [Tree] - -readTree :: MultiGrammar -> String -> Tree -showTree :: Tree -> String - -languages :: MultiGrammar -> [Language] -categories :: MultiGrammar -> [Category] - -startCat :: MultiGrammar -> Category - ---------------------------------------------------- --- Implementation ---------------------------------------------------- - -file2grammar f = do - gfcc <- file2gfcc f - return (MultiGrammar gfcc) - -file2gfcc f = do - s <- readFileIf f - g <- parseGrammar s - return $ toGFCC g - -linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (CId lang) - -parse mgr lang cat s = - case lookParser (gfcc mgr) (CId lang) of - Nothing -> error "no parser" - Just pinfo -> case parseFCF "bottomup" pinfo (CId cat) (words s) of - Ok x -> x - Bad s -> error s - -linearizeAll mgr = map snd . linearizeAllLang mgr -linearizeAllLang mgr t = - [(lang,linearThis 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)] - -generateRandom mgr cat = do - gen <- newStdGen - return $ genRandom gen (gfcc mgr) (CId cat) - -generateAll mgr cat = generate (gfcc mgr) (CId cat) Nothing -generateAllDepth mgr cat = generate (gfcc mgr) (CId cat) - -readTree _ = pTree - -showTree = prExp - -prIdent :: CId -> String -prIdent (CId s) = s - -abstractName mgr = prIdent (absname (gfcc mgr)) - -languages mgr = [l | CId l <- cncnames (gfcc mgr)] - -categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))] - -startCat mgr = lookStartCat (gfcc mgr) - -emptyMultiGrammar = MultiGrammar emptyGFCC - ------------- for internal use only - -linearThis = GF.GFCC.API.linearize - -err f g ex = case ex of - Ok x -> g x - Bad s -> f s - -readFileIf f = do - b <- doesFileExist f - if b then readFile f - else putStrLn ("file " ++ f ++ " not found") >> return "" diff --git a/src/GF/GFCC/CId.hs b/src/GF/GFCC/CId.hs deleted file mode 100644 index e4efa98ba..000000000 --- a/src/GF/GFCC/CId.hs +++ /dev/null @@ -1,14 +0,0 @@ -module GF.GFCC.CId ( - module GF.GFCC.Raw.AbsGFCCRaw, - prCId, - cId - ) where - -import GF.GFCC.Raw.AbsGFCCRaw (CId(CId)) - -prCId :: CId -> String -prCId (CId s) = s - -cId :: String -> CId -cId = CId - diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs deleted file mode 100644 index d59dba1a9..000000000 --- a/src/GF/GFCC/CheckGFCC.hs +++ /dev/null @@ -1,186 +0,0 @@ -module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio, checkGFCCmaybe) where - -import GF.GFCC.CId -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.Data.ErrM - -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace - -checkGFCCio :: GFCC -> IO GFCC -checkGFCCio gfcc = case checkGFCC gfcc of - Ok (gc,b) -> do - putStrLn $ if b then "OK" else "Corrupted GFCC" - return gc - Bad s -> do - putStrLn s - error "building GFCC failed" - ----- needed in old Custom -checkGFCCmaybe :: GFCC -> Maybe GFCC -checkGFCCmaybe gfcc = case checkGFCC gfcc of - Ok (gc,b) -> return gc - Bad s -> Nothing - -checkGFCC :: GFCC -> Err (GFCC,Bool) -checkGFCC gfcc = do - (cs,bs) <- mapM (checkConcrete gfcc) - (Map.assocs (concretes gfcc)) >>= return . unzip - return (gfcc {concretes = Map.fromAscList cs}, and bs) - - --- errors are non-fatal; replace with 'fail' to change this -msg s = trace s (return ()) - -andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool -andMapM f xs = mapM f xs >>= return . and - -labelBoolErr :: String -> Err (x,Bool) -> Err (x,Bool) -labelBoolErr ms iob = do - (x,b) <- iob - if b then return (x,b) else (msg ms >> return (x,b)) - - -checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool) -checkConcrete gfcc (lang,cnc) = - labelBoolErr ("happened in language " ++ printCId lang) $ do - (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip - return ((lang,cnc{lins = Map.fromAscList rs}),and bs) - where - checkl = checkLin gfcc lang - -checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool) -checkLin gfcc lang (f,t) = - labelBoolErr ("happened in function " ++ printCId f) $ do - (t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t - return ((f,t'),b) - -inferTerm :: [CType] -> Term -> Err (Term,CType) -inferTerm args trm = case trm of - K _ -> returnt str - C i -> returnt $ ints i - V i -> do - testErr (i < length args) ("too large index " ++ show i) - returnt $ args !! i - S ts -> do - (ts',tys) <- mapM infer ts >>= return . unzip - let tys' = filter (/=str) tys - testErr (null tys') - ("expected Str in " ++ show trm ++ " not " ++ unwords (map show tys')) - return (S ts',str) - R ts -> do - (ts',tys) <- mapM infer ts >>= return . unzip - return $ (R ts',tuple tys) - P t u -> do - (t',tt) <- infer t - (u',tu) <- infer u - case tt of - R tys -> case tu of - R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]] - --- R [v] -> infer $ P t v - --- R (v:vs) -> infer $ P (head tys) (R vs) - - C i -> do - testErr (i < length tys) - ("required more than " ++ show i ++ " fields in " ++ show (R tys)) - return (P t' u', tys !! i) -- record: index must be known - _ -> do - let typ = head tys - testErr (all (==typ) tys) ("different types in table " ++ show trm) - return (P t' u', typ) -- table: types must be same - _ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt - FV [] -> returnt tm0 ---- - FV (t:ts) -> do - (t',ty) <- infer t - (ts',tys) <- mapM infer ts >>= return . unzip - testErr (all (eqType ty) tys) ("different types in variants " ++ show trm) - return (FV (t':ts'),ty) - W s r -> infer r - _ -> Bad ("no type inference for " ++ show trm) - where - returnt ty = return (trm,ty) - infer = inferTerm args - -checkTerm :: LinType -> Term -> Err (Term,Bool) -checkTerm (args,val) trm = case inferTerm args trm of - Ok (t,ty) -> if eqType ty val - then return (t,True) - else do - msg ("term: " ++ show trm ++ - "\nexpected type: " ++ show val ++ - "\ninferred type: " ++ show ty) - return (t,False) - Bad s -> do - msg s - return (trm,False) - -eqType :: CType -> CType -> Bool -eqType inf exp = case (inf,exp) of - (C k, C n) -> k <= n -- only run-time corr. - (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts] - (TM _, _) -> True ---- for variants [] ; not safe - _ -> inf == exp - --- should be in a generic module, but not in the run-time DataGFCC - -type CType = Term -type LinType = ([CType],CType) - -tuple :: [CType] -> CType -tuple = R - -ints :: Int -> CType -ints = C - -str :: CType -str = S [] - -lintype :: GFCC -> CId -> CId -> LinType -lintype gfcc lang fun = case typeSkeleton (lookType gfcc fun) of - (cs,c) -> (map vlinc cs, linc c) ---- HOAS - where - linc = lookLincat gfcc lang - vlinc (0,c) = linc c - vlinc (i,c) = case linc c of - R ts -> R (ts ++ replicate i str) - -inline :: GFCC -> CId -> Term -> Term -inline gfcc lang t = case t of - F c -> inl $ look c - _ -> composSafeOp inl t - where - inl = inline gfcc lang - look = lookLin gfcc lang - -composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp f trm = case trm of - R ts -> liftM R $ mapM f ts - S ts -> liftM S $ mapM f ts - FV ts -> liftM FV $ mapM f ts - P t u -> liftM2 P (f t) (f u) - W s t -> liftM (W s) $ f t - _ -> return trm - -composSafeOp :: (Term -> Term) -> Term -> Term -composSafeOp f = maybe undefined id . composOp (return . f) - --- from GF.Data.Oper - -maybeErr :: String -> Maybe a -> Err a -maybeErr s = maybe (Bad s) Ok - -testErr :: Bool -> String -> Err () -testErr cond msg = if cond then return () else Bad msg - -errVal :: a -> Err a -> a -errVal a = err (const a) id - -errIn :: String -> Err a -> Err a -errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return - -err :: (String -> b) -> (a -> b) -> Err a -> b -err d f e = case e of - Ok a -> f a - Bad s -> d s diff --git a/src/GF/GFCC/ComposOp.hs b/src/GF/GFCC/ComposOp.hs deleted file mode 100644 index de2522bc7..000000000 --- a/src/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/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs deleted file mode 100644 index 077d62b19..000000000 --- a/src/GF/GFCC/DataGFCC.hs +++ /dev/null @@ -1,152 +0,0 @@ -module GF.GFCC.DataGFCC where - -import GF.GFCC.CId -import GF.Infra.CompactPrint -import GF.Text.UTF8 -import GF.Formalism.FCFG -import GF.Parsing.FCFG.PInfo - -import Data.Map -import Data.List - --- internal datatypes for GFCC - -data GFCC = GFCC { - absname :: CId , - cncnames :: [CId] , - gflags :: Map CId String, -- value of a global flag - abstract :: Abstr , - concretes :: Map CId Concr - } - -data Abstr = Abstr { - aflags :: Map CId String, -- value of a flag - funs :: Map CId (Type,Exp), -- type and def of a fun - cats :: Map CId [Hypo], -- context of a cat - catfuns :: Map CId [CId] -- funs to a cat (redundant, for fast lookup) - } - -data Concr = Concr { - cflags :: Map CId String, -- value of a flag - lins :: Map CId Term, -- lin of a fun - opers :: Map CId Term, -- oper generated by subex elim - lincats :: Map CId Term, -- lin type of a cat - lindefs :: Map CId Term, -- lin default of a cat - printnames :: Map CId Term, -- printname of a cat or a fun - paramlincats :: Map CId Term, -- lin type of cat, with printable param names - parser :: Maybe FCFPInfo -- parser - } - -data Type = - DTyp [Hypo] CId [Exp] - deriving (Eq,Ord,Show) - -data Exp = - DTr [CId] Atom [Exp] - | EEq [Equation] - deriving (Eq,Ord,Show) - -data Atom = - AC CId - | AS String - | AI Integer - | AF Double - | AM Integer - | AV CId - deriving (Eq,Ord,Show) - -data Term = - R [Term] - | P Term Term - | S [Term] - | K Tokn - | V Int - | C Int - | F CId - | FV [Term] - | W String Term - | TM String - | RP Term Term - deriving (Eq,Ord,Show) - -data Tokn = - KS String - | KP [String] [Variant] - deriving (Eq,Ord,Show) - -data Variant = - Var [String] [String] - deriving (Eq,Ord,Show) - -data Hypo = - Hyp CId Type - deriving (Eq,Ord,Show) - -data Equation = - Equ [Exp] Exp - deriving (Eq,Ord,Show) - --- print statistics - -statGFCC :: GFCC -> String -statGFCC gfcc = unlines [ - "Abstract\t" ++ pr (absname gfcc), - "Concretes\t" ++ unwords (lmap pr (cncnames gfcc)), - "Categories\t" ++ unwords (lmap pr (keys (cats (abstract gfcc)))) - ] - where pr (CId s) = s - -printCId :: CId -> String -printCId (CId s) = s - --- merge two GFCCs; fails is differens absnames; priority to second arg - -unionGFCC :: GFCC -> GFCC -> GFCC -unionGFCC one two = case absname one of - CId "" -> two -- extending empty grammar - n | n == absname two -> one { -- extending grammar with same abstract - concretes = Data.Map.union (concretes two) (concretes one), - cncnames = Data.List.union (cncnames two) (cncnames one) - } - _ -> one -- abstracts don't match ---- print error msg - -emptyGFCC :: GFCC -emptyGFCC = GFCC { - absname = CId "", - cncnames = [] , - gflags = empty, - abstract = error "empty grammar, no abstract", - concretes = empty - } - --- default map and filter are for Map here -lmap = Prelude.map -lfilter = Prelude.filter -mmap = Data.Map.map - --- encode idenfifiers and strings in UTF8 - -utf8GFCC :: GFCC -> GFCC -utf8GFCC gfcc = gfcc { - concretes = mmap u8concr (concretes gfcc) - } - where - u8concr cnc = cnc { - lins = mmap u8term (lins cnc), - opers = mmap u8term (opers cnc) - } - u8term = convertStringsInTerm encodeUTF8 - ----- TODO: convert identifiers and flags - -convertStringsInTerm conv t = case t of - K (KS s) -> K (KS (conv s)) - W s r -> W (conv s) (convs r) - R ts -> R $ lmap convs ts - S ts -> S $ lmap convs ts - FV ts -> FV $ lmap convs ts - P u v -> P (convs u) (convs v) - _ -> t - where - convs = convertStringsInTerm conv - diff --git a/src/GF/GFCC/GFCC.cf b/src/GF/GFCC/GFCC.cf deleted file mode 100644 index 96d68649b..000000000 --- a/src/GF/GFCC/GFCC.cf +++ /dev/null @@ -1,81 +0,0 @@ -Grm. Grammar ::= - "grammar" CId "(" [CId] ")" "(" [Flag] ")" ";" - Abstract ";" - [Concrete] ; - -Abs. Abstract ::= - "abstract" "{" - "flags" [Flag] - "fun" [FunDef] - "cat" [CatDef] - "}" ; - -Cnc. Concrete ::= - "concrete" CId "{" - "flags" [Flag] - "lin" [LinDef] - "oper" [LinDef] - "lincat" [LinDef] - "lindef" [LinDef] - "printname" [LinDef] - "param" [LinDef] -- lincats with param value names - "}" ; - -Flg. Flag ::= CId "=" String ; -Cat. CatDef ::= CId "[" [Hypo] "]" ; - -Fun. FunDef ::= CId ":" Type "=" Exp ; -Lin. LinDef ::= CId "=" Term ; - -DTyp. Type ::= "[" [Hypo] "]" CId [Exp] ; -- dependent type -DTr. Exp ::= "[" "(" [CId] ")" Atom [Exp] "]" ; -- term with bindings - -AC. Atom ::= CId ; -AS. Atom ::= String ; -AI. Atom ::= Integer ; -AF. Atom ::= Double ; -AM. Atom ::= "?" Integer ; - -R. Term ::= "[" [Term] "]" ; -- record/table -P. Term ::= "(" Term "!" Term ")" ; -- projection/selection -S. Term ::= "(" [Term] ")" ; -- concatenated sequence -K. Term ::= Tokn ; -- token -V. Term ::= "$" Integer ; -- argument -C. Term ::= Integer ; -- parameter value/label -F. Term ::= CId ; -- global constant -FV. Term ::= "[|" [Term] "|]" ; -- free variation -W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table -TM. Term ::= "?" ; -- lin of metavariable - -KS. Tokn ::= String ; -KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; -Var. Variant ::= [String] "/" [String] ; - - -RP. Term ::= "(" Term "@" Term ")"; -- DEPRECATED: record parameter alias - -terminator Concrete ";" ; -terminator Flag ";" ; -terminator CatDef ";" ; -terminator FunDef ";" ; -terminator LinDef ";" ; -separator CId "," ; -separator Term "," ; -terminator Exp "" ; -terminator String "" ; -separator Variant "," ; - -token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; - - --- the following are needed if dependent types or HOAS or defs are present - -Hyp. Hypo ::= CId ":" Type ; -AV. Atom ::= "$" CId ; - -EEq. Exp ::= "{" [Equation] "}" ; -- list of pattern eqs; primitive: [] -Equ. Equation ::= [Exp] "->" Exp ; -- patterns are encoded as exps - -separator Hypo "," ; -terminator Equation ";" ; - diff --git a/src/GF/GFCC/Generate.hs b/src/GF/GFCC/Generate.hs deleted file mode 100644 index 63bdb3b9a..000000000 --- a/src/GF/GFCC/Generate.hs +++ /dev/null @@ -1,70 +0,0 @@ -module GF.GFCC.Generate where - -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId - -import qualified Data.Map as M -import System.Random - --- generate an infinite list of trees exhaustively -generate :: GFCC -> CId -> Maybe Int -> [Exp] -generate gfcc cat dp = concatMap (\i -> gener i cat) depths - where - gener 0 c = [tree (AC f) [] | (f, ([],_)) <- fns c] - gener i c = [ - tr | - (f, (cs,_)) <- fns c, - let alts = map (gener (i-1)) cs, - ts <- combinations alts, - let tr = tree (AC f) ts, - depth tr >= i - ] - fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat gfcc c] - depths = maybe [0 ..] (\d -> [0..d]) dp - --- generate an infinite list of trees randomly -genRandom :: StdGen -> GFCC -> CId -> [Exp] -genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where - - timeout = 47 -- give up - - genTrees ds0 cat = - let (ds,ds2) = splitAt (timeout+1) ds0 -- for time out, else ds - (t,k) = genTree ds cat - in (if k>timeout then id else (t:)) - (genTrees ds2 cat) -- else (drop k ds) - - genTree rs = gett rs where - gett ds (CId "String") = (tree (AS "foo") [], 1) - gett ds (CId "Int") = (tree (AI 12345) [], 1) - gett [] _ = (tree (AS "TIMEOUT") [], 1) ---- - gett ds cat = case fns cat of - [] -> (tree (AM 0) [],1) - fs -> let - d:ds2 = ds - (f,args) = getf d fs - (ts,k) = getts ds2 args - in (tree (AC f) ts, k+1) - getf d fs = let lg = (length fs) in - fs !! (floor (d * fromIntegral lg)) - 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) - - fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat gfcc cat] - - -{- --- brute-force parsing method; only returns the first result --- note: you cannot throw away rules with unknown words from the grammar --- because it is not known which field in each rule may match the input - -searchParse :: Int -> GFCC -> CId -> [String] -> [Exp] -searchParse i gfcc cat ws = [t | t <- gen, s <- lins t, words s == ws] where - gen = take i $ generate gfcc cat - lins t = [linearize gfcc lang t | lang <- cncnames gfcc] --} diff --git a/src/GF/GFCC/LexGFCC.hs b/src/GF/GFCC/LexGFCC.hs deleted file mode 100644 index c86195e3d..000000000 --- a/src/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/GF/GFCC/Linearize.hs b/src/GF/GFCC/Linearize.hs deleted file mode 100644 index c66ff93c1..000000000 --- a/src/GF/GFCC/Linearize.hs +++ /dev/null @@ -1,91 +0,0 @@ -module GF.GFCC.Linearize where - -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId -import Data.Map -import Data.List - -import Debug.Trace - --- linearization and computation of concrete GFCC Terms - -linearize :: GFCC -> CId -> Exp -> String -linearize mcfg lang = realize . linExp mcfg lang - -realize :: Term -> String -realize trm = case trm of - R ts -> realize (ts !! 0) - S ss -> unwords $ lmap realize ss - K t -> case t of - KS s -> s - KP s _ -> unwords s ---- prefix choice TODO - W s t -> s ++ realize t - FV ts -> realize (ts !! 0) ---- other variants TODO - RP _ r -> realize r ---- DEPREC - TM s -> s - _ -> "ERROR " ++ show trm ---- debug - -linExp :: GFCC -> CId -> Exp -> Term -linExp mcfg lang tree@(DTr xs at trees) = - addB $ case at of - AC fun -> comp (lmap lin trees) $ look fun - AS s -> R [kks (show s)] -- quoted - AI i -> R [kks (show i)] - --- [C lst, kks (show i), C size] where - --- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1 - AF d -> R [kks (show d)] - AV x -> TM (prCId x) - AM i -> TM (show i) - where - lin = linExp mcfg lang - comp = compute mcfg lang - look = lookLin mcfg lang - addB t - | Data.List.null xs = t - | otherwise = case t of - R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) - TM s -> R $ t : (Data.List.map (kks . prCId) xs) - -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute mcfg lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - RP i t -> RP (comp i) (comp t) ---- DEPREC - W s t -> W s (comp t) - R ts -> R $ lmap comp ts - V i -> idx args i -- already computed - F c -> comp $ look c -- not computed (if contains argvar) - FV ts -> FV $ lmap comp ts - S ts -> S $ lfilter (/= S []) $ lmap comp ts - _ -> trm - - look = lookOper mcfg lang - - idx xs i = if i > length xs - 1 - then trace - ("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") tm0 - else xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ lmap (proj r) ts - (FV ts, _ ) -> FV $ lmap (\t -> proj t p) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> i - RP p _ -> getIndex p ---- DEPREC - TM _ -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i ---- DEPREC - TM s -> TM s - _ -> error ("ERROR in grammar compiler: field from " ++ show t) t - diff --git a/src/GF/GFCC/Macros.hs b/src/GF/GFCC/Macros.hs deleted file mode 100644 index 4897aa667..000000000 --- a/src/GF/GFCC/Macros.hs +++ /dev/null @@ -1,121 +0,0 @@ -module GF.GFCC.Macros where - -import GF.GFCC.CId -import GF.GFCC.DataGFCC -import GF.Formalism.FCFG (FGrammar) -import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar) -----import GF.GFCC.PrintGFCC -import Control.Monad -import Data.Map -import Data.Maybe -import Data.List - --- operations for manipulating GFCC grammars and objects - -lookLin :: GFCC -> CId -> CId -> Term -lookLin gfcc lang fun = - lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc - -lookOper :: GFCC -> CId -> CId -> Term -lookOper gfcc lang fun = - lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc - -lookLincat :: GFCC -> CId -> CId -> Term -lookLincat gfcc lang fun = - lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc - -lookParamLincat :: GFCC -> CId -> CId -> Term -lookParamLincat gfcc lang fun = - lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc - -lookType :: GFCC -> CId -> Type -lookType gfcc f = - fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc)) - -lookParser :: GFCC -> CId -> Maybe FCFPInfo -lookParser gfcc lang = parser $ lookMap (error "no lang") lang $ concretes gfcc - -lookFCFG :: GFCC -> CId -> Maybe FGrammar -lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang - -lookStartCat :: GFCC -> String -lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (CId "startcat")) - [gflags gfcc, aflags (abstract gfcc)] - -lookGlobalFlag :: GFCC -> CId -> String -lookGlobalFlag gfcc f = - lookMap "?" f (gflags gfcc) - -lookAbsFlag :: GFCC -> CId -> String -lookAbsFlag gfcc f = - lookMap "?" f (aflags (abstract gfcc)) - -lookCncFlag :: GFCC -> CId -> CId -> String -lookCncFlag gfcc lang f = - lookMap "?" f $ cflags $ lookMap (error "no lang") lang $ concretes gfcc - -functionsToCat :: GFCC -> CId -> [(CId,Type)] -functionsToCat gfcc cat = - [(f,ty) | f <- fs, Just (ty,_) <- [Data.Map.lookup f $ funs $ abstract gfcc]] - where - fs = lookMap [] cat $ catfuns $ abstract gfcc - -depth :: Exp -> Int -depth tr = case tr of - DTr _ _ [] -> 1 - DTr _ _ ts -> maximum (lmap depth ts) + 1 - -tree :: Atom -> [Exp] -> Exp -tree = DTr [] - -cftype :: [CId] -> CId -> Type -cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val [] - -catSkeleton :: Type -> ([CId],CId) -catSkeleton ty = case ty of - DTyp hyps val _ -> ([valCat ty | Hyp _ ty <- hyps],val) - -typeSkeleton :: Type -> ([(Int,CId)],CId) -typeSkeleton ty = case ty of - DTyp hyps val _ -> ([(contextLength ty, valCat ty) | Hyp _ ty <- hyps],val) - -valCat :: Type -> CId -valCat ty = case ty of - DTyp _ val _ -> val - -contextLength :: Type -> Int -contextLength ty = case ty of - DTyp hyps _ _ -> length hyps - -cid :: String -> CId -cid = CId - -wildCId :: CId -wildCId = cid "_" - -exp0 :: Exp -exp0 = tree (AM 0) [] - -primNotion :: Exp -primNotion = EEq [] - -term0 :: CId -> Term -term0 = TM . prCId - -tm0 :: Term -tm0 = TM "?" - -kks :: String -> Term -kks = K . KS - --- lookup with default value -lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a -lookMap d c m = maybe d id $ Data.Map.lookup c m - ---- from Operations -combinations :: [[a]] -> [[a]] -combinations t = case t of - [] -> [[]] - aa:uu -> [a:u | a <- aa, u <- combinations uu] - - diff --git a/src/GF/GFCC/OptimizeGFCC.hs b/src/GF/GFCC/OptimizeGFCC.hs deleted file mode 100644 index 394458041..000000000 --- a/src/GF/GFCC/OptimizeGFCC.hs +++ /dev/null @@ -1,116 +0,0 @@ -module GF.GFCC.OptimizeGFCC where - -import GF.GFCC.CId -import GF.GFCC.DataGFCC - -import GF.Data.Operations - -import Data.List -import qualified Data.Map as Map - - --- back-end optimization: --- suffix analysis followed by common subexpression elimination - -optGFCC :: GFCC -> GFCC -optGFCC gfcc = gfcc { - concretes = Map.map opt (concretes gfcc) - } - where - opt cnc = subex $ cnc { - lins = Map.map optTerm (lins cnc), - lindefs = Map.map optTerm (lindefs cnc), - printnames = Map.map optTerm (printnames cnc) - } - --- analyse word form lists into prefix + suffixes --- suffix sets can later be shared by subex elim - -optTerm :: Term -> Term -optTerm tr = case tr of - R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts] - R ts -> R $ map optTerm ts - P t v -> P (optTerm t) v - _ -> tr - where - optToks ss = prf : suffs where - prf = pref (head ss) (tail ss) - suffs = map (drop (length prf)) ss - pref cand ss = case ss of - s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss - _ -> cand - isK t = case t of - K (KS _) -> True - _ -> False - mkSuff ("":ws) = R (map (K . KS) ws) - mkSuff (p:ws) = W p (R (map (K . KS) ws)) - - --- common subexpression elimination - ----subex :: [(CId,Term)] -> [(CId,Term)] -subex :: Concr -> Concr -subex cnc = errVal cnc $ do - (tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0) - return $ addSubexpConsts tree cnc - -type TermList = Map.Map Term (Int,Int) -- number of occs, id -type TermM a = STM (TermList,Int) a - -addSubexpConsts :: TermList -> Concr -> Concr -addSubexpConsts tree cnc = cnc { - opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops], - lins = rec lins, - lindefs = rec lindefs, - printnames = rec printnames - } - where - ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree] - mkOne (f,trm) = (f, recomp f trm) - recomp f t = case Map.lookup t tree of - Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself - _ -> case t of - R ts -> R $ map (recomp f) ts - S ts -> S $ map (recomp f) ts - W s t -> W s (recomp f t) - P t p -> P (recomp f t) (recomp f p) - _ -> t - fid n = CId $ "_" ++ show n - rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)] - - -getSubtermsMod :: Concr -> TermM TermList -getSubtermsMod cnc = do - mapM getSubterms (Map.assocs (lins cnc)) - mapM getSubterms (Map.assocs (lindefs cnc)) - mapM getSubterms (Map.assocs (printnames cnc)) - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getSubterms (f,trm) = collectSubterms trm >> return () - -collectSubterms :: Term -> TermM () -collectSubterms t = case t of - R ts -> do - mapM collectSubterms ts - add t - S ts -> do - mapM collectSubterms ts - add t - W s u -> do - collectSubterms u - add t - P p u -> do - collectSubterms p - collectSubterms u - add t - _ -> return () - 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) - diff --git a/src/GF/GFCC/Raw/AbsGFCCRaw.hs b/src/GF/GFCC/Raw/AbsGFCCRaw.hs deleted file mode 100644 index ab5f184a8..000000000 --- a/src/GF/GFCC/Raw/AbsGFCCRaw.hs +++ /dev/null @@ -1,17 +0,0 @@ -module GF.GFCC.Raw.AbsGFCCRaw where - --- Haskell module generated by the BNF converter - -newtype CId = CId String deriving (Eq,Ord,Show) -data Grammar = - Grm [RExp] - deriving (Eq,Ord,Show) - -data RExp = - App CId [RExp] - | AInt Integer - | AStr String - | AFlt Double - | AMet - deriving (Eq,Ord,Show) - diff --git a/src/GF/GFCC/Raw/ConvertGFCC.hs b/src/GF/GFCC/Raw/ConvertGFCC.hs deleted file mode 100644 index 0b010d604..000000000 --- a/src/GF/GFCC/Raw/ConvertGFCC.hs +++ /dev/null @@ -1,277 +0,0 @@ -module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where - -import GF.GFCC.DataGFCC -import GF.GFCC.Raw.AbsGFCCRaw - -import GF.Data.Assoc -import GF.Formalism.FCFG -import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) -import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo) - -import qualified Data.Array as Array -import Data.Map - -pgfMajorVersion, pgfMinorVersion :: Integer -(pgfMajorVersion, pgfMinorVersion) = (1,0) - --- convert parsed grammar to internal GFCC - -toGFCC :: Grammar -> GFCC -toGFCC (Grm [ - App (CId "pgf") (AInt v1 : AInt v2 : App a []:cs), - App (CId "flags") gfs, - ab@( - App (CId "abstract") [ - App (CId "fun") fs, - App (CId "cat") cts - ]), - App (CId "concrete") ccs - ]) = GFCC { - absname = a, - cncnames = [c | App c [] <- cs], - gflags = fromAscList [(f,v) | App f [AStr v] <- gfs], - abstract = - let - aflags = fromAscList [(f,v) | App f [AStr v] <- gfs] - lfuns = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs] - funs = fromAscList lfuns - lcats = [(c, Prelude.map toHypo hyps) | App c hyps <- cts] - cats = fromAscList lcats - catfuns = fromAscList - [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - in Abstr aflags funs cats catfuns, - concretes = fromAscList [(lang, toConcr ts) | App lang ts <- ccs] - } - where - -toConcr :: [RExp] -> Concr -toConcr = foldl add (Concr { - cflags = empty, - lins = empty, - opers = empty, - lincats = empty, - lindefs = empty, - printnames = empty, - paramlincats = empty, - parser = Nothing - }) - where - add :: Concr -> RExp -> Concr - add cnc (App (CId "flags") ts) = cnc { cflags = fromAscList [(f,v) | App f [AStr v] <- ts] } - add cnc (App (CId "lin") ts) = cnc { lins = mkTermMap ts } - add cnc (App (CId "oper") ts) = cnc { opers = mkTermMap ts } - add cnc (App (CId "lincat") ts) = cnc { lincats = mkTermMap ts } - add cnc (App (CId "lindef") ts) = cnc { lindefs = mkTermMap ts } - add cnc (App (CId "printname") ts) = cnc { printnames = mkTermMap ts } - add cnc (App (CId "param") ts) = cnc { paramlincats = mkTermMap ts } - add cnc (App (CId "parser") ts) = cnc { parser = Just (toPInfo ts) } - -toPInfo :: [RExp] -> FCFPInfo -toPInfo [App (CId "rules") rs, App (CId "startupcats") cs] = buildFCFPInfo (rules, cats) - where - rules = lmap toFRule rs - cats = fromList [(c, lmap expToInt fs) | App c fs <- cs] - - toFRule :: RExp -> FRule - toFRule (App (CId "rule") - [n, - App (CId "cats") (rt:at), - App (CId "R") ls]) = FRule name args res lins - where - name = toFName n - args = lmap expToInt at - res = expToInt rt - lins = mkArray [mkArray [toSymbol s | s <- l] | App (CId "S") l <- ls] - -toFName :: RExp -> FName -toFName (App (CId "_A") [x]) = Name (CId "_") [Unify [expToInt x]] -toFName (App f ts) = Name f (lmap toProfile ts) - where - toProfile :: RExp -> Profile (SyntaxForest CId) - toProfile AMet = Unify [] - toProfile (App (CId "_A") [t]) = Unify [expToInt t] - toProfile (App (CId "_U") ts) = Unify [expToInt t | App (CId "_A") [t] <- ts] - toProfile t = Constant (toSyntaxForest t) - - toSyntaxForest :: RExp -> SyntaxForest CId - toSyntaxForest AMet = FMeta - toSyntaxForest (App n ts) = FNode n [lmap toSyntaxForest ts] - toSyntaxForest (AStr s) = FString s - toSyntaxForest (AInt i) = FInt i - toSyntaxForest (AFlt f) = FFloat f - -toSymbol :: RExp -> FSymbol -toSymbol (App (CId "P") [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n) -toSymbol (AStr t) = FSymTok t - -toType :: RExp -> Type -toType e = case e of - App cat [App (CId "H") hypos, App (CId "X") exps] -> - DTyp (lmap toHypo hypos) cat (lmap toExp exps) - _ -> error $ "type " ++ show e - -toHypo :: RExp -> Hypo -toHypo e = case e of - App x [typ] -> Hyp x (toType typ) - _ -> error $ "hypo " ++ show e - -toExp :: RExp -> Exp -toExp e = case e of - App (CId "App") [App fun [], App (CId "B") xs, App (CId "X") exps] -> - DTr [x | App x [] <- xs] (AC fun) (lmap toExp exps) - App (CId "Eq") eqs -> - EEq [Equ (lmap toExp ps) (toExp v) | App (CId "E") (v:ps) <- eqs] - App (CId "Var") [App i []] -> DTr [] (AV i) [] - AMet -> DTr [] (AM 0) [] - AInt i -> DTr [] (AI i) [] - AFlt i -> DTr [] (AF i) [] - AStr i -> DTr [] (AS i) [] - _ -> error $ "exp " ++ show e - -toTerm :: RExp -> Term -toTerm e = case e of - App (CId "R") es -> R (lmap toTerm es) - App (CId "S") es -> S (lmap toTerm es) - App (CId "FV") es -> FV (lmap toTerm es) - App (CId "P") [e,v] -> P (toTerm e) (toTerm v) - App (CId "RP") [e,v] -> RP (toTerm e) (toTerm v) ---- - App (CId "W") [AStr s,v] -> W s (toTerm v) - App (CId "A") [AInt i] -> V (fromInteger i) - App f [] -> F f - AInt i -> C (fromInteger i) - AMet -> TM "?" - AStr s -> K (KS s) ---- - _ -> error $ "term " ++ show e - ------------------------------- ---- from internal to parser -- ------------------------------- - -fromGFCC :: GFCC -> Grammar -fromGFCC gfcc0 = Grm [ - app "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion - : App (absname gfcc) [] : lmap (flip App []) (cncnames gfcc)), - app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)], - app "abstract" [ - app "fun" [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)], - app "cat" [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)] - ], - app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)] - ] - where - gfcc = utf8GFCC gfcc0 - app s = App (CId s) - agfcc = abstract gfcc - fromConcrete cnc = [ - app "flags" [App f [AStr v] | (f,v) <- toList (cflags cnc)], - app "lin" [App f [fromTerm v] | (f,v) <- toList (lins cnc)], - app "oper" [App f [fromTerm v] | (f,v) <- toList (opers cnc)], - app "lincat" [App f [fromTerm v] | (f,v) <- toList (lincats cnc)], - app "lindef" [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)], - app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)], - app "param" [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)] - ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc) - -fromType :: Type -> RExp -fromType e = case e of - DTyp hypos cat exps -> - App cat [ - App (CId "H") (lmap fromHypo hypos), - App (CId "X") (lmap fromExp exps)] - -fromHypo :: Hypo -> RExp -fromHypo e = case e of - Hyp x typ -> App x [fromType typ] - -fromExp :: Exp -> RExp -fromExp e = case e of - DTr xs (AC fun) exps -> - App (CId "App") [App fun [], App (CId "B") (lmap (flip App []) xs), App (CId "X") (lmap fromExp exps)] - DTr [] (AV x) [] -> App (CId "Var") [App x []] - DTr [] (AS s) [] -> AStr s - DTr [] (AF d) [] -> AFlt d - DTr [] (AI i) [] -> AInt (toInteger i) - DTr [] (AM _) [] -> AMet ---- - EEq eqs -> - App (CId "Eq") [App (CId "E") (lmap fromExp (v:ps)) | Equ ps v <- eqs] - _ -> error $ "exp " ++ show e - -fromTerm :: Term -> RExp -fromTerm e = case e of - R es -> app "R" (lmap fromTerm es) - S es -> app "S" (lmap fromTerm es) - FV es -> app "FV" (lmap fromTerm es) - P e v -> app "P" [fromTerm e, fromTerm v] - RP e v -> app "RP" [fromTerm e, fromTerm v] ---- - W s v -> app "W" [AStr s, fromTerm v] - C i -> AInt (toInteger i) - TM _ -> AMet - F f -> App f [] - V i -> App (CId "A") [AInt (toInteger i)] - K (KS s) -> AStr s ---- - K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ---- - where - app = App . CId - str v = app "S" (lmap AStr v) - --- ** Parsing info - -fromPInfo :: FCFPInfo -> RExp -fromPInfo p = app "parser" [ - app "rules" [fromFRule rule | rule <- Array.elems (allRules p)], - app "startupcats" [App f (lmap intToExp cs) | (f,cs) <- toList (startupCats p)] - ] - -fromFRule :: FRule -> RExp -fromFRule (FRule n args res lins) = - app "rule" [fromFName n, - app "cats" (intToExp res:lmap intToExp args), - app "R" [app "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins] - ] - -fromFName :: FName -> RExp -fromFName n = case n of - Name (CId "_") [p] -> fromProfile p - Name f ps -> App f (lmap fromProfile ps) - where - fromProfile :: Profile (SyntaxForest CId) -> RExp - fromProfile (Unify []) = AMet - fromProfile (Unify [x]) = daughter x - fromProfile (Unify args) = app "_U" (lmap daughter args) - fromProfile (Constant forest) = fromSyntaxForest forest - - daughter n = app "_A" [intToExp n] - - fromSyntaxForest :: SyntaxForest CId -> RExp - fromSyntaxForest FMeta = AMet - -- FIXME: is there always just one element here? - fromSyntaxForest (FNode n [args]) = App n (lmap fromSyntaxForest args) - fromSyntaxForest (FString s) = AStr s - fromSyntaxForest (FInt i) = AInt i - fromSyntaxForest (FFloat f) = AFlt f - -fromSymbol :: FSymbol -> RExp -fromSymbol (FSymCat c l n) = app "P" [intToExp c, intToExp n, intToExp l] -fromSymbol (FSymTok t) = AStr t - --- ** Utilities - -mkTermMap :: [RExp] -> Map CId Term -mkTermMap ts = fromAscList [(f,toTerm v) | App f [v] <- ts] - -app :: String -> [RExp] -> RExp -app = App . CId - -mkArray :: [a] -> Array.Array Int a -mkArray xs = Array.listArray (0, length xs - 1) xs - -expToInt :: Integral a => RExp -> a -expToInt (App (CId "neg") [AInt i]) = fromIntegral (negate i) -expToInt (AInt i) = fromIntegral i - -expToStr :: RExp -> String -expToStr (AStr s) = s - -intToExp :: Integral a => a -> RExp -intToExp x | x < 0 = App (CId "neg") [AInt (fromIntegral (negate x))] - | otherwise = AInt (fromIntegral x) diff --git a/src/GF/GFCC/Raw/GFCCRaw.cf b/src/GF/GFCC/Raw/GFCCRaw.cf deleted file mode 100644 index bedaef685..000000000 --- a/src/GF/GFCC/Raw/GFCCRaw.cf +++ /dev/null @@ -1,12 +0,0 @@ -Grm. Grammar ::= [RExp] ; - -App. RExp ::= "(" CId [RExp] ")" ; -AId. RExp ::= CId ; -AInt. RExp ::= Integer ; -AStr. RExp ::= String ; -AFlt. RExp ::= Double ; -AMet. RExp ::= "?" ; - -terminator RExp "" ; - -token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; diff --git a/src/GF/GFCC/Raw/ParGFCCRaw.hs b/src/GF/GFCC/Raw/ParGFCCRaw.hs deleted file mode 100644 index b71904948..000000000 --- a/src/GF/GFCC/Raw/ParGFCCRaw.hs +++ /dev/null @@ -1,99 +0,0 @@ -module GF.GFCC.Raw.ParGFCCRaw (parseGrammar) where - -import GF.GFCC.Raw.AbsGFCCRaw - -import Control.Monad -import Data.Char - -parseGrammar :: String -> IO Grammar -parseGrammar s = case runP pGrammar s of - Just (x,"") -> return x - _ -> fail "Parse error" - -pGrammar :: P Grammar -pGrammar = liftM Grm pTerms - -pTerms :: P [RExp] -pTerms = liftM2 (:) (pTerm 1) pTerms <++ (skipSpaces >> return []) - -pTerm :: Int -> P RExp -pTerm n = skipSpaces >> (pParen <++ pApp <++ pNum <++ pStr <++ pMeta) - where pParen = between (char '(') (char ')') (pTerm 0) - pApp = liftM2 App pIdent (if n == 0 then pTerms else return []) - pStr = char '"' >> liftM AStr (manyTill (pEsc <++ get) (char '"')) - pEsc = char '\\' >> get - pNum = do x <- munch1 isDigit - ((char '.' >> munch1 isDigit >>= \y -> return (AFlt (read (x++"."++y)))) - <++ - return (AInt (read x))) - pMeta = char '?' >> return AMet - pIdent = liftM CId $ liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest) - isIdentFirst c = c == '_' || isAlpha c - isIdentRest c = c == '_' || c == '\'' || isAlphaNum c - --- Parser combinators with only left-biased choice - -newtype P a = P { runP :: String -> Maybe (a,String) } - -instance Monad P where - return x = P (\ts -> Just (x,ts)) - P p >>= f = P (\ts -> p ts >>= \ (x,ts') -> runP (f x) ts') - fail _ = pfail - -instance MonadPlus P where - mzero = pfail - mplus = (<++) - - -get :: P Char -get = P (\ts -> case ts of - [] -> Nothing - c:cs -> Just (c,cs)) - -look :: P String -look = P (\ts -> Just (ts,ts)) - -(<++) :: P a -> P a -> P a -P p <++ P q = P (\ts -> p ts `mplus` q ts) - -pfail :: P a -pfail = P (\ts -> Nothing) - -satisfy :: (Char -> Bool) -> P Char -satisfy p = do c <- get - if p c then return c else pfail - -char :: Char -> P Char -char c = satisfy (c==) - -string :: String -> P String -string this = look >>= scan this - where - scan [] _ = return this - scan (x:xs) (y:ys) | x == y = get >> scan xs ys - scan _ _ = pfail - -skipSpaces :: P () -skipSpaces = look >>= skip - where - skip (c:s) | isSpace c = get >> skip s - skip _ = return () - -manyTill :: P a -> P end -> P [a] -manyTill p end = scan - where scan = (end >> return []) <++ liftM2 (:) p scan - -munch :: (Char -> Bool) -> P String -munch p = munch1 p <++ return [] - -munch1 :: (Char -> Bool) -> P String -munch1 p = liftM2 (:) (satisfy p) (munch p) - -choice :: [P a] -> P a -choice = msum - -between :: P open -> P close -> P a -> P a -between open close p = do open - x <- p - close - return x diff --git a/src/GF/GFCC/Raw/PrintGFCCRaw.hs b/src/GF/GFCC/Raw/PrintGFCCRaw.hs deleted file mode 100644 index d46d8096f..000000000 --- a/src/GF/GFCC/Raw/PrintGFCCRaw.hs +++ /dev/null @@ -1,36 +0,0 @@ -module GF.GFCC.Raw.PrintGFCCRaw (printTree) where - -import GF.GFCC.Raw.AbsGFCCRaw - -import Data.List (intersperse) -import Numeric (showFFloat) - -printTree :: Grammar -> String -printTree g = prGrammar g "" - -prGrammar :: Grammar -> ShowS -prGrammar (Grm xs) = prRExpList xs - -prRExp :: Int -> RExp -> ShowS -prRExp _ (App x []) = prCId x -prRExp n (App x xs) = p (prCId x . showChar ' ' . prRExpList xs) - where p s = if n == 0 then s else showChar '(' . s . showChar ')' -prRExp _ (AInt x) = shows x -prRExp _ (AStr x) = showChar '"' . concatS (map mkEsc x) . showChar '"' -prRExp _ (AFlt x) = showFFloat Nothing x -prRExp _ AMet = showChar '?' - -mkEsc :: Char -> ShowS -mkEsc s = case s of - '"' -> showString "\\\"" - '\\' -> showString "\\\\" - _ -> showChar s - -prRExpList :: [RExp] -> ShowS -prRExpList = concatS . intersperse (showChar ' ') . map (prRExp 1) - -prCId :: CId -> ShowS -prCId (CId x) = showString x - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id diff --git a/src/GF/GFCC/ShowLinearize.hs b/src/GF/GFCC/ShowLinearize.hs deleted file mode 100644 index f627dfd28..000000000 --- a/src/GF/GFCC/ShowLinearize.hs +++ /dev/null @@ -1,87 +0,0 @@ -module GF.GFCC.ShowLinearize ( - tableLinearize, - recordLinearize, - termLinearize, - allLinearize - ) where - -import GF.GFCC.Linearize -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId ---import GF.GFCC.PrintGFCC ---- - -import GF.Data.Operations -import Data.List - --- printing linearizations in different ways with source parameters - --- internal representation, only used internally in this module -data Record = - RR [(String,Record)] - | RT [(String,Record)] - | RFV [Record] - | RS String - | RCon String - -prRecord :: Record -> String -prRecord = prr where - prr t = case t of - RR fs -> concat $ - "{" : - (intersperse ";" (map (\ (l,v) -> unwords [l,"=", prr v]) fs)) ++ ["}"] - RT fs -> concat $ - "table {" : - (intersperse ";" (map (\ (l,v) -> unwords [l,"=>",prr v]) fs)) ++ ["}"] - RFV ts -> concat $ - "variants {" : (intersperse ";" (map prr ts)) ++ ["}"] - RS s -> prQuotedString s - RCon s -> s - --- uses the encoding of record types in GFCC.paramlincat -mkRecord :: Term -> Term -> Record -mkRecord typ trm = case (typ,trm) of - (R rs, R ts) -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts] - (S [FV ps,ty],R ts) -> RT [(str par, mkRecord ty t) | (par, t) <- zip ps ts] - (_,W s (R ts)) -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts]) - (FV ps, C i) -> RCon $ str $ ps !! i - (S [], _) -> RS $ realize trm - _ -> RS $ show trm ---- printTree trm - where - str = realize - --- show all branches, without labels and params -allLinearize :: GFCC -> CId -> Exp -> String -allLinearize gfcc lang = concat . map pr . tabularLinearize gfcc lang where - pr (p,vs) = unlines vs - --- show all branches, with labels and params -tableLinearize :: GFCC -> CId -> Exp -> String -tableLinearize gfcc lang = unlines . map pr . tabularLinearize gfcc lang where - pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs) - --- create a table from labels+params to variants -tabularLinearize :: GFCC -> CId -> Exp -> [(String,[String])] -tabularLinearize gfcc lang = branches . recLinearize gfcc lang where - branches r = case r of - RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t] - RT fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t] - RFV rs -> [([], ss) | (_,ss) <- concatMap branches rs] - RS s -> [([], [s])] - RCon _ -> [] - --- show record in GF-source-like syntax -recordLinearize :: GFCC -> CId -> Exp -> String -recordLinearize gfcc lang = prRecord . recLinearize gfcc lang - --- create a GF-like record, forming the basis of all functions above -recLinearize :: GFCC -> CId -> Exp -> Record -recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where - typ = case exp of - DTr _ (AC f) _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f - --- show GFCC term -termLinearize :: GFCC -> CId -> Exp -> String -termLinearize gfcc lang = show . linExp gfcc lang - - diff --git a/src/GF/GFCC/SkelGFCC.hs b/src/GF/GFCC/SkelGFCC.hs deleted file mode 100644 index 6972fd3c3..000000000 --- a/src/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/GF/GFCC/TestGFCC.hs b/src/GF/GFCC/TestGFCC.hs deleted file mode 100644 index c379a687a..000000000 --- a/src/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/GF/GFCC/doc/Eng.gf b/src/GF/GFCC/doc/Eng.gf deleted file mode 100644 index c64f46313..000000000 --- a/src/GF/GFCC/doc/Eng.gf +++ /dev/null @@ -1,13 +0,0 @@ -concrete Eng of Ex = { - lincat - S = {s : Str} ; - NP = {s : Str ; n : Num} ; - VP = {s : Num => Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = {s = np.s ++ vp.s ! np.n} ; - She = {s = "she" ; n = Sg} ; - They = {s = "they" ; n = Pl} ; - Sleep = {s = table {Sg => "sleeps" ; Pl => "sleep"}} ; -} diff --git a/src/GF/GFCC/doc/Ex.gf b/src/GF/GFCC/doc/Ex.gf deleted file mode 100644 index bd0b03483..000000000 --- a/src/GF/GFCC/doc/Ex.gf +++ /dev/null @@ -1,8 +0,0 @@ -abstract Ex = { - cat - S ; NP ; VP ; - fun - Pred : NP -> VP -> S ; - She, They : NP ; - Sleep : VP ; -} diff --git a/src/GF/GFCC/doc/Swe.gf b/src/GF/GFCC/doc/Swe.gf deleted file mode 100644 index 1d6672371..000000000 --- a/src/GF/GFCC/doc/Swe.gf +++ /dev/null @@ -1,13 +0,0 @@ -concrete Swe of Ex = { - lincat - S = {s : Str} ; - NP = {s : Str} ; - VP = {s : Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = {s = np.s ++ vp.s} ; - She = {s = "hon"} ; - They = {s = "de"} ; - Sleep = {s = "sover"} ; -} diff --git a/src/GF/GFCC/doc/Test.gf b/src/GF/GFCC/doc/Test.gf deleted file mode 100644 index 5cd4c5474..000000000 --- a/src/GF/GFCC/doc/Test.gf +++ /dev/null @@ -1,64 +0,0 @@ --- to test GFCC compilation - -flags coding=utf8 ; - -cat S ; NP ; N ; VP ; - -fun Pred : NP -> VP -> S ; -fun Pred2 : NP -> VP -> NP -> S ; -fun Det, Dets : N -> NP ; -fun Mina, Sina, Me, Te : NP ; -fun Raha, Paska, Pallo : N ; -fun Puhua, Munia, Sanoa : VP ; - -param Person = P1 | P2 | P3 ; -param Number = Sg | Pl ; -param Case = Nom | Part ; - -param NForm = NF Number Case ; -param VForm = VF Number Person ; - -lincat N = Noun ; -lincat VP = Verb ; - -oper Noun = {s : NForm => Str} ; -oper Verb = {s : VForm => Str} ; - -lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ; - -lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ; -lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ; -lin Det no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ; -lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ; -lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ; -lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ; -lin Sina = {s = table Case ["sinä" ; "sinua"] ; a = {n = Sg ; p = P2}} ; -lin Me = {s = table Case ["me" ; "meitä"] ; a = {n = Pl ; p = P1}} ; - -lin Raha = mkN "raha" ; -lin Paska = mkN "paska" ; -lin Pallo = mkN "pallo" ; -lin Puhua = mkV "puhu" ; -lin Munia = mkV "muni" ; -lin Sanoa = mkV "sano" ; - -oper mkN : Str -> Noun = \raha -> { - s = table { - NF Sg Nom => raha ; - NF Sg Part => raha + "a" ; - NF Pl Nom => raha + "t" ; - NF Pl Part => Predef.tk 1 raha + "oja" - } - } ; - -oper mkV : Str -> Verb = \puhu -> { - s = table { - VF Sg P1 => puhu + "n" ; - VF Sg P2 => puhu + "t" ; - VF Sg P3 => puhu + Predef.dp 1 puhu ; - VF Pl P1 => puhu + "mme" ; - VF Pl P2 => puhu + "tte" ; - VF Pl P3 => puhu + "vat" - } - } ; - diff --git a/src/GF/GFCC/doc/gfcc.html b/src/GF/GFCC/doc/gfcc.html deleted file mode 100644 index 8f8c478c0..000000000 --- a/src/GF/GFCC/doc/gfcc.html +++ /dev/null @@ -1,809 +0,0 @@ - - - - -The GFCC Grammar Format - -

The GFCC Grammar Format

- -Aarne Ranta
-October 5, 2007 -
- -

-Author's address: -http://www.cs.chalmers.se/~aarne -

-

-History: -

-
    -
  • 5 Oct 2007: new, better structured GFCC with full expressive power -
  • 19 Oct: translation of lincats, new figures on C++ -
  • 3 Oct 2006: first version -
- -

What is GFCC

-

-GFCC is a low-level format for GF grammars. Its aim is to contain the minimum -that is needed to process GF grammars at runtime. This minimality has three -advantages: -

-
    -
  • compact grammar files and run-time objects -
  • time and space efficient processing -
  • simple definition of interpreters -
- -

-Thus we also want to call GFCC the portable grammar format. -

-

-The idea is that all embedded GF applications use GFCC. -The GF system would be primarily used as a compiler and as a grammar -development tool. -

-

-Since GFCC is implemented in BNFC, a parser of the format is readily -available for C, C++, C#, Haskell, Java, and OCaml. Also an XML -representation can be generated in BNFC. A -reference implementation -of linearization and some other functions has been written in Haskell. -

-

GFCC vs. GFC

-

-GFCC is aimed to replace GFC as the run-time grammar format. GFC was designed -to be a run-time format, but also to -support separate compilation of grammars, i.e. -to store the results of compiling -individual GF modules. But this means that GFC has to contain extra information, -such as type annotations, which is only needed in compilation and not at -run-time. In particular, the pattern matching syntax and semantics of GFC is -complex and therefore difficult to implement in new platforms. -

-

-Actually, GFC is planned to be omitted also as the target format of -separate compilation, where plain GF (type annotated and partially evaluated) -will be used instead. GFC provides only marginal advantages as a target format -compared with GF, and it is therefore just extra weight to carry around this -format. -

-

-The main differences of GFCC compared with GFC (and GF) can be summarized as follows: -

-
    -
  • there are no modules, and therefore no qualified names -
  • a GFCC grammar is multilingual, and consists of a common abstract syntax - together with one concrete syntax per language -
  • records and tables are replaced by arrays -
  • record labels and parameter values are replaced by integers -
  • record projection and table selection are replaced by array indexing -
  • even though the format does support dependent types and higher-order abstract - syntax, there is no interpreted yet that does this -
- -

-Here is an example of a GF grammar, consisting of three modules, -as translated to GFCC. The representations are aligned; thus they do not completely -reflect the order of judgements in GFCC files, which have different orders of -blocks of judgements, and alphabetical sorting. -

-
-                                      grammar Ex(Eng,Swe);
-  
-  abstract Ex = {                     abstract {
-    cat                                 cat
-      S ; NP ; VP ;                      NP[]; S[]; VP[];
-    fun                                 fun
-      Pred : NP -> VP -> S ;             Pred=[(($ 0! 1),(($ 1! 0)!($ 0! 0)))];
-      She, They : NP ;                   She=[0,"she"];
-      Sleep : VP ;                       They=[1,"they"];
-                                         Sleep=[["sleeps","sleep"]];
-  }                                     } ;
-                                      
-  concrete Eng of Ex = {              concrete Eng {
-    lincat                             lincat
-      S  = {s : Str} ;                  S=[()];
-      NP = {s : Str ; n : Num} ;        NP=[1,()];
-      VP = {s : Num => Str} ;           VP=[[(),()]];
-    param
-      Num = Sg | Pl ;
-    lin                                lin
-      Pred np vp = {                    Pred=[(($ 0! 1),(($ 1! 0)!($ 0! 0)))];
-        s = np.s ++ vp.s ! np.n} ;      
-      She = {s = "she" ; n = Sg} ;      She=[0,"she"];
-      They = {s = "they" ; n = Pl} ;    They = [1, "they"];
-      Sleep = {s = table {              Sleep=[["sleeps","sleep"]];
-        Sg => "sleeps" ; 
-        Pl => "sleep"                   
-        }                               
-      } ;
-  }                                   } ;
-  
-  concrete Swe of Ex = {              concrete Swe {
-    lincat                             lincat
-      S  = {s : Str} ;                  S=[()];
-      NP = {s : Str} ;                  NP=[()];
-      VP = {s : Str} ;                  VP=[()];
-    param
-      Num = Sg | Pl ;
-    lin                                lin
-      Pred np vp = {                    Pred = [(($0!0),($1!0))];
-        s = np.s ++ vp.s} ;
-      She = {s = "hon"} ;               She = ["hon"];
-      They = {s = "de"} ;               They = ["de"];
-      Sleep = {s = "sover"} ;           Sleep = ["sover"];
-  }                                     } ;                                   
-
-

-

The syntax of GFCC files

-

-The complete BNFC grammar, from which -the rules in this section are taken, is in the file -GF/GFCC/GFCC.cf. -

-

Top level

-

-A grammar has a header telling the name of the abstract syntax -(often specifying an application domain), and the names of -the concrete languages. The abstract syntax and the concrete -syntaxes themselves follow. -

-
-    Grm. Grammar  ::= 
-      "grammar" CId "(" [CId] ")" ";" 
-      Abstract ";" 
-      [Concrete] ;
-  
-    Abs. Abstract ::= 
-      "abstract" "{" 
-        "flags" [Flag] 
-        "fun"   [FunDef] 
-        "cat"   [CatDef] 
-      "}" ;
-  
-    Cnc. Concrete ::= 
-      "concrete" CId "{" 
-        "flags"  [Flag] 
-        "lin"    [LinDef] 
-        "oper"   [LinDef] 
-        "lincat" [LinDef] 
-        "lindef" [LinDef] 
-        "printname" [LinDef]
-      "}" ;
-
-

-This syntax organizes each module to a sequence of fields, such -as flags, linearizations, operations, linearization types, etc. -It is envisaged that particular applications can ignore some -of the fields, typically so that earlier fields are more -important than later ones. -

-

-The judgement forms have the following syntax. -

-
-    Flg. Flag     ::= CId "=" String ;
-    Cat. CatDef   ::= CId "[" [Hypo] "]" ;
-    Fun. FunDef   ::= CId ":" Type "=" Exp ;
-    Lin. LinDef   ::= CId "=" Term ;
-
-

-For the run-time system, the reference implementation in Haskell -uses a structure that gives efficient look-up: -

-
-    data GFCC = GFCC {
-      absname   :: CId ,
-      cncnames  :: [CId] ,
-      abstract  :: Abstr ,
-      concretes :: Map CId Concr
-      }
-  
-    data Abstr = Abstr {
-      aflags  :: Map CId String,     -- value of a flag
-      funs    :: Map CId (Type,Exp), -- type and def of a fun
-      cats    :: Map CId [Hypo],     -- context of a cat
-      catfuns :: Map CId [CId]       -- funs yielding a cat (redundant, for fast lookup)
-      }
-  
-    data Concr = Concr {
-      flags   :: Map CId String, -- value of a flag
-      lins    :: Map CId Term,   -- lin of a fun
-      opers   :: Map CId Term,   -- oper generated by subex elim
-      lincats :: Map CId Term,   -- lin type of a cat
-      lindefs :: Map CId Term,   -- lin default of a cat
-      printnames :: Map CId Term -- printname of a cat or a fun
-      }
-
-

-These definitions are from GF/GFCC/DataGFCC.hs. -

-

-Identifiers (CId) are like Ident in GF, except that -the compiler produces constants prefixed with _ in -the common subterm elimination optimization. -

-
-    token CId (('_' | letter) (letter | digit | '\'' | '_')*) ;
-
-

-

Abstract syntax

-

-Types are first-order function types built from argument type -contexts and value types. -category symbols. Syntax trees (Exp) are -rose trees with nodes consisting of a head (Atom) and -bound variables (CId). -

-
-    DTyp. Type  ::= "[" [Hypo] "]" CId [Exp] ;        
-    DTr.  Exp   ::= "[" "(" [CId] ")" Atom [Exp] "]" ;
-    Hyp.  Hypo  ::= CId ":" Type ;
-
-

-The head Atom is either a function -constant, a bound variable, or a metavariable, or a string, integer, or float -literal. -

-
-    AC.   Atom  ::= CId ;
-    AS.   Atom  ::= String ;
-    AI.   Atom  ::= Integer ;
-    AF.   Atom  ::= Double ;
-    AM.   Atom  ::= "?" Integer ;
-
-

-The context-free types and trees of the "old GFCC" are special -cases, which can be defined as follows: -

-
-    Typ.  Type  ::= [CId] "->" CId
-    Typ args val = DTyp [Hyp (CId "_") arg | arg <- args] val
-  
-    Tr.   Exp   ::= "(" CId [Exp] ")"
-    Tr fun exps  = DTr [] fun exps
-
-

-To store semantic (def) definitions by cases, the following expression -form is provided, but it is only meaningful in the last field of a function -declaration in an abstract syntax: -

-
-    EEq. Exp      ::= "{" [Equation] "}" ;
-    Equ. Equation ::= [Exp] "->" Exp ;
-
-

-Notice that expressions are used to encode patterns. Primitive notions -(the default semantics in GF) are encoded as empty sets of equations -([]). For a constructor (canonical form) of a category C, we -aim to use the encoding as the application (_constr C). -

-

Concrete syntax

-

-Linearization terms (Term) are built as follows. -Constructor names are shown to make the later code -examples readable. -

-
-    R.  Term ::= "[" [Term] "]" ;        -- array (record/table)
-    P.  Term ::= "(" Term "!" Term ")" ; -- access to field (projection/selection)
-    S.  Term ::= "(" [Term] ")" ;        -- concatenated sequence
-    K.  Term ::= Tokn ;                  -- token
-    V.  Term ::= "$" Integer ;           -- argument (subtree)
-    C.  Term ::= Integer ;               -- array index (label/parameter value)
-    FV. Term ::= "[|" [Term] "|]" ;      -- free variation
-    TM. Term ::= "?" ;                   -- linearization of metavariable
-
-

-Tokens are strings or (maybe obsolescent) prefix-dependent -variant lists. -

-
-    KS.  Tokn     ::= String ;
-    KP.  Tokn     ::= "[" "pre" [String] "[" [Variant] "]" "]" ;
-    Var. Variant  ::= [String] "/" [String] ;
-
-

-Two special forms of terms are introduced by the compiler -as optimizations. They can in principle be eliminated, but -their presence makes grammars much more compact. Their semantics -will be explained in a later section. -

-
-    F.  Term ::= CId ;                     -- global constant
-    W.  Term ::= "(" String "+" Term ")" ; -- prefix + suffix table
-
-

-There is also a deprecated form of "record parameter alias", -

-
-    RP. Term ::= "(" Term "@" Term ")";    -- DEPRECATED
-
-

-which will be removed when the migration to new GFCC is complete. -

-

The semantics of concrete syntax terms

-

-The code in this section is from GF/GFCC/Linearize.hs. -

-

Linearization and realization

-

-The linearization algorithm is essentially the same as in -GFC: a tree is linearized by evaluating its linearization term -in the environment of the linearizations of the subtrees. -Literal atoms are linearized in the obvious way. -The function also needs to know the language (i.e. concrete syntax) -in which linearization is performed. -

-
-    linExp :: GFCC -> CId -> Exp -> Term
-    linExp gfcc lang tree@(DTr _ at trees) = case at of
-      AC fun -> comp (Prelude.map lin trees) $ look fun
-      AS s   -> R [kks (show s)] -- quoted
-      AI i   -> R [kks (show i)]
-      AF d   -> R [kks (show d)]
-      AM     -> TM
-     where
-       lin  = linExp gfcc lang
-       comp = compute gfcc lang
-       look = lookLin gfcc lang
-
-

-TODO: bindings must be supported. -

-

-The result of linearization is usually a record, which is realized as -a string using the following algorithm. -

-
-    realize :: Term -> String
-    realize trm = case trm of
-      R (t:_)  -> realize t
-      S ss     -> unwords $ Prelude.map realize ss
-      K (KS s) -> s
-      K (KP s _) -> unwords s ---- prefix choice TODO
-      W s t    -> s ++ realize t
-      FV (t:_) -> realize t
-      TM       -> "?"
-
-

-Notice that realization always picks the first field of a record. -If a linearization type has more than one field, the first field -does not necessarily contain the desired string. -Also notice that the order of record fields in GFCC is not necessarily -the same as in GF source. -

-

Term evaluation

-

-Evaluation follows call-by-value order, with two environments -needed: -

-
    -
  • the grammar (a concrete syntax) to give the global constants -
  • an array of terms to give the subtree linearizations -
- -

-The code is presented in one-level pattern matching, to -enable reimplementations in languages that do not permit -deep patterns (such as Java and C++). -

-
-  compute :: GFCC -> CId -> [Term] -> Term -> Term
-  compute gfcc lang args = comp where
-    comp trm = case trm of
-      P r p  -> proj (comp r) (comp p)
-      W s t  -> W s (comp t)
-      R ts   -> R $ Prelude.map comp ts
-      V i    -> idx args (fromInteger i)  -- already computed
-      F c    -> comp $ look c             -- not computed (if contains V)
-      FV ts  -> FV $ Prelude.map comp ts
-      S ts   -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts
-      _ -> trm
-  
-    look = lookOper gfcc lang
-  
-    idx xs i = xs !! i
-  
-    proj r p = case (r,p) of
-      (_,     FV ts) -> FV $ Prelude.map (proj r) ts
-      (W s t, _)     -> kks (s ++ getString (proj t p))
-      _              -> comp $ getField r (getIndex p)
-  
-    getString t = case t of
-      K (KS s) -> s
-      _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR"
-  
-    getIndex t =  case t of
-      C i    -> fromInteger i
-      RP p _ -> getIndex p
-      TM     -> 0  -- default value for parameter
-      _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0
-  
-    getField t i = case t of
-      R rs   -> idx rs i
-      RP _ r -> getField r i
-      TM     -> TM
-      _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t
-
-

-

The special term constructors

-

-The three forms introduced by the compiler may a need special -explanation. -

-

-Global constants -

-
-    Term ::= CId ;
-
-

-are shorthands for complex terms. They are produced by the -compiler by (iterated) common subexpression elimination. -They are often more powerful than hand-devised code sharing in the source -code. They could be computed off-line by replacing each identifier by -its definition. -

-

-Prefix-suffix tables -

-
-    Term ::= "(" String "+" Term ")" ; 
-
-

-represent tables of word forms divided to the longest common prefix -and its array of suffixes. In the example grammar above, we have -

-
-    Sleep = [("sleep" + ["s",""])]
-
-

-which in fact is equal to the array of full forms -

-
-    ["sleeps", "sleep"]
-
-

-The power of this construction comes from the fact that suffix sets -tend to be repeated in a language, and can therefore be collected -by common subexpression elimination. It is this technique that -explains the used syntax rather than the more accurate -

-
-    "(" String "+" [String] ")"
-
-

-since we want the suffix part to be a Term for the optimization to -take effect. -

-

Compiling to GFCC

-

-Compilation to GFCC is performed by the GF grammar compiler, and -GFCC interpreters need not know what it does. For grammar writers, -however, it might be interesting to know what happens to the grammars -in the process. -

-

-The compilation phases are the following -

-
    -
  1. type check and partially evaluate GF source -
  2. create a symbol table mapping the GF parameter and record types to - fixed-size arrays, and parameter values and record labels to integers -
  3. traverse the linearization rules replacing parameters and labels by integers -
  4. reorganize the created GF grammar so that it has just one abstract syntax - and one concrete syntax per language -
  5. TODO: apply UTF8 encoding to the grammar, if not yet applied (this is told by the - coding flag) -
  6. translate the GF grammar object to a GFCC grammar object, using a simple - compositional mapping -
  7. perform the word-suffix optimization on GFCC linearization terms -
  8. perform subexpression elimination on each concrete syntax module -
  9. print out the GFCC code -
- -

Problems in GFCC compilation

-

-Two major problems had to be solved in compiling GF to GFCC: -

-
    -
  • consistent order of tables and records, to permit the array translation -
  • run-time variables in complex parameter values. -
- -

-The current implementation is still experimental and may fail -to generate correct code. Any errors remaining are likely to be -related to the two problems just mentioned. -

-

-The order problem is solved in slightly different ways for tables and records. -In both cases, eta expansion is used to establish a -canonical order. Tables are ordered by applying the preorder induced -by param definitions. Records are ordered by sorting them by labels. -This means that -e.g. the s field will in general no longer appear as the first -field, even if it does so in the GF source code. But relying on the -order of fields in a labelled record would be misplaced anyway. -

-

-The canonical form of records is further complicated by lock fields, -i.e. dummy fields of form lock_C = <>, which are added to grammar -libraries to force intensionality of linearization types. The problem -is that the absence of a lock field only generates a warning, not -an error. Therefore a GF grammar can contain objects of the same -type with and without a lock field. This problem was solved in GFCC -generation by just removing all lock fields (defined as fields whose -type is the empty record type). This has the further advantage of -(slightly) reducing the grammar size. More importantly, it is safe -to remove lock fields, because they are never used in computation, -and because intensional types are only needed in grammars reused -as libraries, not in grammars used at runtime. -

-

-While the order problem is rather bureaucratic in nature, run-time -variables are an interesting problem. They arise in the presence -of complex parameter values, created by argument-taking constructors -and parameter records. To give an example, consider the GF parameter -type system -

-
-    Number = Sg | Pl ;
-    Person = P1 | P2 | P3 ;
-    Agr = Ag Number Person ;
-
-

-The values can be translated to integers in the expected way, -

-
-    Sg = 0, Pl = 1
-    P1 = 0, P2 = 1, P3 = 2
-    Ag Sg P1 = 0, Ag Sg P2 = 1, Ag Sg P3 = 2,
-    Ag Pl P1 = 3, Ag Pl P2 = 4, Ag Pl P3 = 5
-
-

-However, an argument of Agr can be a run-time variable, as in -

-
-    Ag np.n P3
-
-

-This expression must first be translated to a case expression, -

-
-    case np.n of {
-      0 => 2 ;
-      1 => 5
-      }
-
-

-which can then be translated to the GFCC term -

-
-    ([2,5] ! ($0 ! $1))  
-
-

-assuming that the variable np is the first argument and that its -Number field is the second in the record. -

-

-This transformation of course has to be performed recursively, since -there can be several run-time variables in a parameter value: -

-
-    Ag np.n np.p
-
-

-A similar transformation would be possible to deal with the double -role of parameter records discussed above. Thus the type -

-
-    RNP = {n : Number ; p : Person}
-
-

-could be uniformly translated into the set {0,1,2,3,4,5} -as Agr above. Selections would be simple instances of indexing. -But any projection from the record should be translated into -a case expression, -

-
-    rnp.n  ===> 
-    case rnp of {
-      0 => 0 ;
-      1 => 0 ;
-      2 => 0 ;
-      3 => 1 ;
-      4 => 1 ;
-      5 => 1
-      }
-
-

-To avoid the code bloat resulting from this, we have chosen to -deal with records by a currying transformation: -

-
-    table {n : Number ; p : Person} {... ...}
-     ===>
-    table Number {Sg => table Person {...} ; table Person {...}}
-
-

-This is performed when GFCC is generated. Selections with -records have to be treated likewise, -

-
-    t ! r   ===> t ! r.n ! r.p
-
-

-

The representation of linearization types

-

-Linearization types (lincat) are not needed when generating with -GFCC, but they have been added to enable parser generation directly from -GFCC. The linearization type definitions are shown as a part of the -concrete syntax, by using terms to represent types. Here is the table -showing how different linearization types are encoded. -

-
-    P*                         = max(P)         -- parameter type
-    {r1 : T1 ; ... ; rn : Tn}* = [T1*,...,Tn*]  -- record
-    (P => T)*                  = [T* ,...,T*]   -- table, size(P) cases
-    Str*                       = ()
-
-

-For example, the linearization type present/CatEng.NP is -translated as follows: -

-
-    NP = {
-      a : {                     -- 6 = 2*3 values
-        n : {ParamX.Number} ;   -- 2 values
-        p : {ParamX.Person}     -- 3 values
-      } ;
-      s : {ResEng.Case} => Str  -- 3 values
-    }
-  
-    __NP = [[1,2],[(),(),()]]
-
-

-

Running the compiler and the GFCC interpreter

-

-GFCC generation is a part of the -developers' version -of GF since September 2006. To invoke the compiler, the flag --printer=gfcc to the command -pm = print_multi is used. It is wise to recompile the grammar from -source, since previously compiled libraries may not obey the canonical -order of records. -Here is an example, performed in -example/bronzeage. -

-
-    i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageEng.gf
-    i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageGer.gf
-    strip
-    pm -printer=gfcc | wf bronze.gfcc
-
-

-There is also an experimental batch compiler, which does not use the GFC -format or the record aliases. It can be produced by -

-
-    make gfc
-
-

-in GF/src, and invoked by -

-
-    gfc --make FILES
-
-

-

The reference interpreter

-

-The reference interpreter written in Haskell consists of the following files: -

-
-    -- source file for BNFC
-    GFCC.cf       -- labelled BNF grammar of gfcc
-  
-    -- files generated by BNFC
-    AbsGFCC.hs    -- abstrac syntax datatypes
-    ErrM.hs       -- error monad used internally
-    LexGFCC.hs    -- lexer of gfcc files
-    ParGFCC.hs    -- parser of gfcc files and syntax trees
-    PrintGFCC.hs  -- printer of gfcc files and syntax trees
-  
-    -- hand-written files
-    DataGFCC.hs   -- grammar datatype, post-parser grammar creation
-    Linearize.hs  -- linearization and evaluation
-    Macros.hs     -- utilities abstracting away from GFCC datatypes
-    Generate.hs   -- random and exhaustive generation, generate-and-test parsing
-    API.hs        -- functionalities accessible in embedded GF applications
-    Generate.hs   -- random and exhaustive generation
-    Shell.hs      -- main function - a simple command interpreter
-
-

-It is included in the -developers' version -of GF, in the subdirectories GF/src/GF/GFCC and -GF/src/GF/Devel. -

-

-As of September 2007, default parsing in main GF uses GFCC (implemented by Krasimir -Angelov). The interpreter uses the relevant modules -

-
-    GF/Conversions/SimpleToFCFG.hs  -- generate parser from GFCC
-    GF/Parsing/FCFG.hs              -- run the parser
-
-

-

-To compile the interpreter, type -

-
-    make gfcc
-
-

-in GF/src. To run it, type -

-
-    ./gfcc <GFCC-file>
-
-

-The available commands are -

-
    -
  • gr <Cat> <Int>: generate a number of random trees in category. - and show their linearizations in all languages -
  • grt <Cat> <Int>: generate a number of random trees in category. - and show the trees and their linearizations in all languages -
  • gt <Cat> <Int>: generate a number of trees in category from smallest, - and show their linearizations in all languages -
  • gtt <Cat> <Int>: generate a number of trees in category from smallest, - and show the trees and their linearizations in all languages -
  • p <Lang> <Cat> <String>: parse a string into a set of trees -
  • lin <Tree>: linearize tree in all languages, also showing full records -
  • q: terminate the system cleanly -
- -

Embedded formats

-
    -
  • JavaScript: compiler of linearization and abstract syntax -

    -
  • Haskell: compiler of abstract syntax and interpreter with parsing, - linearization, and generation -

    -
  • C: compiler of linearization (old GFCC) -

    -
  • C++: embedded interpreter supporting linearization (old GFCC) -
- -

Some things to do

-

-Support for dependent types, higher-order abstract syntax, and -semantic definition in GFCC generation and interpreters. -

-

-Replacing the entire GF shell by one based on GFCC. -

-

-Interpreter in Java. -

-

-Hand-written parsers for GFCC grammars to reduce code size -(and efficiency?) of interpreters. -

-

-Binary format and/or file compression of GFCC output. -

-

-Syntax editor based on GFCC. -

-

-Rewriting of resource libraries in order to exploit the -word-suffix sharing better (depth-one tables, as in FM). -

- - - - diff --git a/src/GF/GFCC/doc/gfcc.txt b/src/GF/GFCC/doc/gfcc.txt deleted file mode 100644 index 5dcf2fbdc..000000000 --- a/src/GF/GFCC/doc/gfcc.txt +++ /dev/null @@ -1,712 +0,0 @@ -The GFCC Grammar Format -Aarne Ranta -December 14, 2007 - -Author's address: -[``http://www.cs.chalmers.se/~aarne`` http://www.cs.chalmers.se/~aarne] - -% to compile: txt2tags -thtml --toc gfcc.txt - -History: -- 14 Dec 2007: simpler, Lisp-like concrete syntax of GFCC -- 5 Oct 2007: new, better structured GFCC with full expressive power -- 19 Oct: translation of lincats, new figures on C++ -- 3 Oct 2006: first version - - -==What is GFCC== - -GFCC is a low-level format for GF grammars. Its aim is to contain the minimum -that is needed to process GF grammars at runtime. This minimality has three -advantages: -- compact grammar files and run-time objects -- time and space efficient processing -- simple definition of interpreters - - -Thus we also want to call GFCC the **portable grammar format**. - -The idea is that all embedded GF applications use GFCC. -The GF system would be primarily used as a compiler and as a grammar -development tool. - -Since GFCC is implemented in BNFC, a parser of the format is readily -available for C, C++, C#, Haskell, Java, and OCaml. Also an XML -representation can be generated in BNFC. A -[reference implementation ../] -of linearization and some other functions has been written in Haskell. - - -==GFCC vs. GFC== - -GFCC is aimed to replace GFC as the run-time grammar format. GFC was designed -to be a run-time format, but also to -support separate compilation of grammars, i.e. -to store the results of compiling -individual GF modules. But this means that GFC has to contain extra information, -such as type annotations, which is only needed in compilation and not at -run-time. In particular, the pattern matching syntax and semantics of GFC is -complex and therefore difficult to implement in new platforms. - -Actually, GFC is planned to be omitted also as the target format of -separate compilation, where plain GF (type annotated and partially evaluated) -will be used instead. GFC provides only marginal advantages as a target format -compared with GF, and it is therefore just extra weight to carry around this -format. - -The main differences of GFCC compared with GFC (and GF) can be -summarized as follows: -- there are no modules, and therefore no qualified names -- a GFCC grammar is multilingual, and consists of a common abstract syntax - together with one concrete syntax per language -- records and tables are replaced by arrays -- record labels and parameter values are replaced by integers -- record projection and table selection are replaced by array indexing -- even though the format does support dependent types and higher-order abstract - syntax, there is no interpreted yet that does this - - - -Here is an example of a GF grammar, consisting of three modules, -as translated to GFCC. The representations are aligned; -thus they do not completely -reflect the order of judgements in GFCC files, which have different orders of -blocks of judgements, and alphabetical sorting. -``` - grammar Ex(Eng,Swe); - -abstract Ex = { abstract { - cat cat - S ; NP ; VP ; NP[]; S[]; VP[]; - fun fun - Pred : NP -> VP -> S ; Pred=[(($ 0! 1),(($ 1! 0)!($ 0! 0)))]; - She, They : NP ; She=[0,"she"]; - Sleep : VP ; They=[1,"they"]; - Sleep=[["sleeps","sleep"]]; -} } ; - -concrete Eng of Ex = { concrete Eng { - lincat lincat - S = {s : Str} ; S=[()]; - NP = {s : Str ; n : Num} ; NP=[1,()]; - VP = {s : Num => Str} ; VP=[[(),()]]; - param - Num = Sg | Pl ; - lin lin - Pred np vp = { Pred=[(($ 0! 1),(($ 1! 0)!($ 0! 0)))]; - s = np.s ++ vp.s ! np.n} ; - She = {s = "she" ; n = Sg} ; She=[0,"she"]; - They = {s = "they" ; n = Pl} ; They = [1, "they"]; - Sleep = {s = table { Sleep=[["sleeps","sleep"]]; - Sg => "sleeps" ; - Pl => "sleep" - } - } ; -} } ; - -concrete Swe of Ex = { concrete Swe { - lincat lincat - S = {s : Str} ; S=[()]; - NP = {s : Str} ; NP=[()]; - VP = {s : Str} ; VP=[()]; - param - Num = Sg | Pl ; - lin lin - Pred np vp = { Pred = [(($0!0),($1!0))]; - s = np.s ++ vp.s} ; - She = {s = "hon"} ; She = ["hon"]; - They = {s = "de"} ; They = ["de"]; - Sleep = {s = "sover"} ; Sleep = ["sover"]; -} } ; -``` - -==The syntax of GFCC files== - -The complete BNFC grammar, from which -the rules in this section are taken, is in the file -[``GF/GFCC/GFCC.cf`` ../DataGFCC.cf]. - - -===Top level=== - -A grammar has a header telling the name of the abstract syntax -(often specifying an application domain), and the names of -the concrete languages. The abstract syntax and the concrete -syntaxes themselves follow. -``` - Grm. Grammar ::= - "grammar" CId "(" [CId] ")" ";" - Abstract ";" - [Concrete] ; - - Abs. Abstract ::= - "abstract" "{" - "flags" [Flag] - "fun" [FunDef] - "cat" [CatDef] - "}" ; - - Cnc. Concrete ::= - "concrete" CId "{" - "flags" [Flag] - "lin" [LinDef] - "oper" [LinDef] - "lincat" [LinDef] - "lindef" [LinDef] - "printname" [LinDef] - "}" ; -``` -This syntax organizes each module to a sequence of **fields**, such -as flags, linearizations, operations, linearization types, etc. -It is envisaged that particular applications can ignore some -of the fields, typically so that earlier fields are more -important than later ones. - -The judgement forms have the following syntax. -``` - Flg. Flag ::= CId "=" String ; - Cat. CatDef ::= CId "[" [Hypo] "]" ; - Fun. FunDef ::= CId ":" Type "=" Exp ; - Lin. LinDef ::= CId "=" Term ; -``` -For the run-time system, the reference implementation in Haskell -uses a structure that gives efficient look-up: -``` - data GFCC = GFCC { - absname :: CId , - cncnames :: [CId] , - abstract :: Abstr , - concretes :: Map CId Concr - } - - data Abstr = Abstr { - aflags :: Map CId String, -- value of a flag - funs :: Map CId (Type,Exp), -- type and def of a fun - cats :: Map CId [Hypo], -- context of a cat - catfuns :: Map CId [CId] -- funs yielding a cat (redundant, for fast lookup) - } - - data Concr = Concr { - flags :: Map CId String, -- value of a flag - lins :: Map CId Term, -- lin of a fun - opers :: Map CId Term, -- oper generated by subex elim - lincats :: Map CId Term, -- lin type of a cat - lindefs :: Map CId Term, -- lin default of a cat - printnames :: Map CId Term -- printname of a cat or a fun - } -``` -These definitions are from [``GF/GFCC/DataGFCC.hs`` ../DataGFCC.hs]. - -Identifiers (``CId``) are like ``Ident`` in GF, except that -the compiler produces constants prefixed with ``_`` in -the common subterm elimination optimization. -``` - token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; -``` - - -===Abstract syntax=== - -Types are first-order function types built from argument type -contexts and value types. -category symbols. Syntax trees (``Exp``) are -rose trees with nodes consisting of a head (``Atom``) and -bound variables (``CId``). -``` - DTyp. Type ::= "[" [Hypo] "]" CId [Exp] ; - DTr. Exp ::= "[" "(" [CId] ")" Atom [Exp] "]" ; - Hyp. Hypo ::= CId ":" Type ; -``` -The head Atom is either a function -constant, a bound variable, or a metavariable, or a string, integer, or float -literal. -``` - AC. Atom ::= CId ; - AS. Atom ::= String ; - AI. Atom ::= Integer ; - AF. Atom ::= Double ; - AM. Atom ::= "?" Integer ; -``` -The context-free types and trees of the "old GFCC" are special -cases, which can be defined as follows: -``` - Typ. Type ::= [CId] "->" CId - Typ args val = DTyp [Hyp (CId "_") arg | arg <- args] val - - Tr. Exp ::= "(" CId [Exp] ")" - Tr fun exps = DTr [] fun exps -``` -To store semantic (``def``) definitions by cases, the following expression -form is provided, but it is only meaningful in the last field of a function -declaration in an abstract syntax: -``` - EEq. Exp ::= "{" [Equation] "}" ; - Equ. Equation ::= [Exp] "->" Exp ; -``` -Notice that expressions are used to encode patterns. Primitive notions -(the default semantics in GF) are encoded as empty sets of equations -(``[]``). For a constructor (canonical form) of a category ``C``, we -aim to use the encoding as the application ``(_constr C)``. - - - -===Concrete syntax=== - -Linearization terms (``Term``) are built as follows. -Constructor names are shown to make the later code -examples readable. -``` - R. Term ::= "[" [Term] "]" ; -- array (record/table) - P. Term ::= "(" Term "!" Term ")" ; -- access to field (projection/selection) - S. Term ::= "(" [Term] ")" ; -- concatenated sequence - K. Term ::= Tokn ; -- token - V. Term ::= "$" Integer ; -- argument (subtree) - C. Term ::= Integer ; -- array index (label/parameter value) - FV. Term ::= "[|" [Term] "|]" ; -- free variation - TM. Term ::= "?" ; -- linearization of metavariable -``` -Tokens are strings or (maybe obsolescent) prefix-dependent -variant lists. -``` - KS. Tokn ::= String ; - KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; - Var. Variant ::= [String] "/" [String] ; -``` -Two special forms of terms are introduced by the compiler -as optimizations. They can in principle be eliminated, but -their presence makes grammars much more compact. Their semantics -will be explained in a later section. -``` - F. Term ::= CId ; -- global constant - W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table -``` -There is also a deprecated form of "record parameter alias", -``` - RP. Term ::= "(" Term "@" Term ")"; -- DEPRECATED -``` -which will be removed when the migration to new GFCC is complete. - - - -==The semantics of concrete syntax terms== - -The code in this section is from [``GF/GFCC/Linearize.hs`` ../Linearize.hs]. - - -===Linearization and realization=== - -The linearization algorithm is essentially the same as in -GFC: a tree is linearized by evaluating its linearization term -in the environment of the linearizations of the subtrees. -Literal atoms are linearized in the obvious way. -The function also needs to know the language (i.e. concrete syntax) -in which linearization is performed. -``` - linExp :: GFCC -> CId -> Exp -> Term - linExp gfcc lang tree@(DTr _ at trees) = case at of - AC fun -> comp (Prelude.map lin trees) $ look fun - AS s -> R [kks (show s)] -- quoted - AI i -> R [kks (show i)] - AF d -> R [kks (show d)] - AM -> TM - where - lin = linExp gfcc lang - comp = compute gfcc lang - look = lookLin gfcc lang -``` -TODO: bindings must be supported. - -The result of linearization is usually a record, which is realized as -a string using the following algorithm. -``` - realize :: Term -> String - realize trm = case trm of - R (t:_) -> realize t - S ss -> unwords $ Prelude.map realize ss - K (KS s) -> s - K (KP s _) -> unwords s ---- prefix choice TODO - W s t -> s ++ realize t - FV (t:_) -> realize t - TM -> "?" -``` -Notice that realization always picks the first field of a record. -If a linearization type has more than one field, the first field -does not necessarily contain the desired string. -Also notice that the order of record fields in GFCC is not necessarily -the same as in GF source. - - -===Term evaluation=== - -Evaluation follows call-by-value order, with two environments -needed: -- the grammar (a concrete syntax) to give the global constants -- an array of terms to give the subtree linearizations - - -The code is presented in one-level pattern matching, to -enable reimplementations in languages that do not permit -deep patterns (such as Java and C++). -``` -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute gfcc lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - W s t -> W s (comp t) - R ts -> R $ Prelude.map comp ts - V i -> idx args (fromInteger i) -- already computed - F c -> comp $ look c -- not computed (if contains V) - FV ts -> FV $ Prelude.map comp ts - S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts - _ -> trm - - look = lookOper gfcc lang - - idx xs i = xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ Prelude.map (proj r) ts - (FV ts, _ ) -> FV $ Prelude.map (\t -> proj t p) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> fromInteger i - RP p _ -> getIndex p - TM -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i - TM -> TM - _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t -``` - -===The special term constructors=== - -The three forms introduced by the compiler may a need special -explanation. - -Global constants -``` - Term ::= CId ; -``` -are shorthands for complex terms. They are produced by the -compiler by (iterated) **common subexpression elimination**. -They are often more powerful than hand-devised code sharing in the source -code. They could be computed off-line by replacing each identifier by -its definition. - -**Prefix-suffix tables** -``` - Term ::= "(" String "+" Term ")" ; -``` -represent tables of word forms divided to the longest common prefix -and its array of suffixes. In the example grammar above, we have -``` - Sleep = [("sleep" + ["s",""])] -``` -which in fact is equal to the array of full forms -``` - ["sleeps", "sleep"] -``` -The power of this construction comes from the fact that suffix sets -tend to be repeated in a language, and can therefore be collected -by common subexpression elimination. It is this technique that -explains the used syntax rather than the more accurate -``` - "(" String "+" [String] ")" -``` -since we want the suffix part to be a ``Term`` for the optimization to -take effect. - - - -==Compiling to GFCC== - -Compilation to GFCC is performed by the GF grammar compiler, and -GFCC interpreters need not know what it does. For grammar writers, -however, it might be interesting to know what happens to the grammars -in the process. - -The compilation phases are the following -+ type check and partially evaluate GF source -+ create a symbol table mapping the GF parameter and record types to - fixed-size arrays, and parameter values and record labels to integers -+ traverse the linearization rules replacing parameters and labels by integers -+ reorganize the created GF grammar so that it has just one abstract syntax - and one concrete syntax per language -+ TODO: apply UTF8 encoding to the grammar, if not yet applied (this is told by the - ``coding`` flag) -+ translate the GF grammar object to a GFCC grammar object, using a simple - compositional mapping -+ perform the word-suffix optimization on GFCC linearization terms -+ perform subexpression elimination on each concrete syntax module -+ print out the GFCC code - - - - -===Problems in GFCC compilation=== - -Two major problems had to be solved in compiling GF to GFCC: -- consistent order of tables and records, to permit the array translation -- run-time variables in complex parameter values. - - -The current implementation is still experimental and may fail -to generate correct code. Any errors remaining are likely to be -related to the two problems just mentioned. - -The order problem is solved in slightly different ways for tables and records. -In both cases, **eta expansion** is used to establish a -canonical order. Tables are ordered by applying the preorder induced -by ``param`` definitions. Records are ordered by sorting them by labels. -This means that -e.g. the ``s`` field will in general no longer appear as the first -field, even if it does so in the GF source code. But relying on the -order of fields in a labelled record would be misplaced anyway. - -The canonical form of records is further complicated by lock fields, -i.e. dummy fields of form ``lock_C = <>``, which are added to grammar -libraries to force intensionality of linearization types. The problem -is that the absence of a lock field only generates a warning, not -an error. Therefore a GF grammar can contain objects of the same -type with and without a lock field. This problem was solved in GFCC -generation by just removing all lock fields (defined as fields whose -type is the empty record type). This has the further advantage of -(slightly) reducing the grammar size. More importantly, it is safe -to remove lock fields, because they are never used in computation, -and because intensional types are only needed in grammars reused -as libraries, not in grammars used at runtime. - -While the order problem is rather bureaucratic in nature, run-time -variables are an interesting problem. They arise in the presence -of complex parameter values, created by argument-taking constructors -and parameter records. To give an example, consider the GF parameter -type system -``` - Number = Sg | Pl ; - Person = P1 | P2 | P3 ; - Agr = Ag Number Person ; -``` -The values can be translated to integers in the expected way, -``` - Sg = 0, Pl = 1 - P1 = 0, P2 = 1, P3 = 2 - Ag Sg P1 = 0, Ag Sg P2 = 1, Ag Sg P3 = 2, - Ag Pl P1 = 3, Ag Pl P2 = 4, Ag Pl P3 = 5 -``` -However, an argument of ``Agr`` can be a run-time variable, as in -``` - Ag np.n P3 -``` -This expression must first be translated to a case expression, -``` - case np.n of { - 0 => 2 ; - 1 => 5 - } -``` -which can then be translated to the GFCC term -``` - ([2,5] ! ($0 ! $1)) -``` -assuming that the variable ``np`` is the first argument and that its -``Number`` field is the second in the record. - -This transformation of course has to be performed recursively, since -there can be several run-time variables in a parameter value: -``` - Ag np.n np.p -``` -A similar transformation would be possible to deal with the double -role of parameter records discussed above. Thus the type -``` - RNP = {n : Number ; p : Person} -``` -could be uniformly translated into the set ``{0,1,2,3,4,5}`` -as ``Agr`` above. Selections would be simple instances of indexing. -But any projection from the record should be translated into -a case expression, -``` - rnp.n ===> - case rnp of { - 0 => 0 ; - 1 => 0 ; - 2 => 0 ; - 3 => 1 ; - 4 => 1 ; - 5 => 1 - } -``` -To avoid the code bloat resulting from this, we have chosen to -deal with records by a **currying** transformation: -``` - table {n : Number ; p : Person} {... ...} - ===> - table Number {Sg => table Person {...} ; table Person {...}} -``` -This is performed when GFCC is generated. Selections with -records have to be treated likewise, -``` - t ! r ===> t ! r.n ! r.p -``` - - -===The representation of linearization types=== - -Linearization types (``lincat``) are not needed when generating with -GFCC, but they have been added to enable parser generation directly from -GFCC. The linearization type definitions are shown as a part of the -concrete syntax, by using terms to represent types. Here is the table -showing how different linearization types are encoded. -``` - P* = max(P) -- parameter type - {r1 : T1 ; ... ; rn : Tn}* = [T1*,...,Tn*] -- record - (P => T)* = [T* ,...,T*] -- table, size(P) cases - Str* = () -``` -For example, the linearization type ``present/CatEng.NP`` is -translated as follows: -``` - NP = { - a : { -- 6 = 2*3 values - n : {ParamX.Number} ; -- 2 values - p : {ParamX.Person} -- 3 values - } ; - s : {ResEng.Case} => Str -- 3 values - } - - __NP = [[1,2],[(),(),()]] -``` - - - - -===Running the compiler and the GFCC interpreter=== - -GFCC generation is a part of the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF since September 2006. To invoke the compiler, the flag -``-printer=gfcc`` to the command -``pm = print_multi`` is used. It is wise to recompile the grammar from -source, since previously compiled libraries may not obey the canonical -order of records. -Here is an example, performed in -[example/bronzeage ../../../../../examples/bronzeage]. -``` - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageEng.gf - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageGer.gf - strip - pm -printer=gfcc | wf bronze.gfcc -``` -There is also an experimental batch compiler, which does not use the GFC -format or the record aliases. It can be produced by -``` - make gfc -``` -in ``GF/src``, and invoked by -``` - gfc --make FILES -``` - - - - -==The reference interpreter== - -The reference interpreter written in Haskell consists of the following files: -``` - -- source file for BNFC - GFCC.cf -- labelled BNF grammar of gfcc - - -- files generated by BNFC - AbsGFCC.hs -- abstrac syntax datatypes - ErrM.hs -- error monad used internally - LexGFCC.hs -- lexer of gfcc files - ParGFCC.hs -- parser of gfcc files and syntax trees - PrintGFCC.hs -- printer of gfcc files and syntax trees - - -- hand-written files - DataGFCC.hs -- grammar datatype, post-parser grammar creation - Linearize.hs -- linearization and evaluation - Macros.hs -- utilities abstracting away from GFCC datatypes - Generate.hs -- random and exhaustive generation, generate-and-test parsing - API.hs -- functionalities accessible in embedded GF applications - Generate.hs -- random and exhaustive generation - Shell.hs -- main function - a simple command interpreter -``` -It is included in the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF, in the subdirectories [``GF/src/GF/GFCC`` ../] and -[``GF/src/GF/Devel`` ../../Devel]. - -As of September 2007, default parsing in main GF uses GFCC (implemented by Krasimir -Angelov). The interpreter uses the relevant modules -``` - GF/Conversions/SimpleToFCFG.hs -- generate parser from GFCC - GF/Parsing/FCFG.hs -- run the parser -``` - - -To compile the interpreter, type -``` - make gfcc -``` -in ``GF/src``. To run it, type -``` - ./gfcc -``` -The available commands are -- ``gr ``: generate a number of random trees in category. - and show their linearizations in all languages -- ``grt ``: generate a number of random trees in category. - and show the trees and their linearizations in all languages -- ``gt ``: generate a number of trees in category from smallest, - and show their linearizations in all languages -- ``gtt ``: generate a number of trees in category from smallest, - and show the trees and their linearizations in all languages -- ``p ``: parse a string into a set of trees -- ``lin ``: linearize tree in all languages, also showing full records -- ``q``: terminate the system cleanly - - - -==Embedded formats== - -- JavaScript: compiler of linearization and abstract syntax - -- Haskell: compiler of abstract syntax and interpreter with parsing, - linearization, and generation - -- C: compiler of linearization (old GFCC) - -- C++: embedded interpreter supporting linearization (old GFCC) - - - -==Some things to do== - -Support for dependent types, higher-order abstract syntax, and -semantic definition in GFCC generation and interpreters. - -Replacing the entire GF shell by one based on GFCC. - -Interpreter in Java. - -Hand-written parsers for GFCC grammars to reduce code size -(and efficiency?) of interpreters. - -Binary format and/or file compression of GFCC output. - -Syntax editor based on GFCC. - -Rewriting of resource libraries in order to exploit the -word-suffix sharing better (depth-one tables, as in FM). - diff --git a/src/GF/GFCC/doc/old-GFCC.cf b/src/GF/GFCC/doc/old-GFCC.cf deleted file mode 100644 index 65657a259..000000000 --- a/src/GF/GFCC/doc/old-GFCC.cf +++ /dev/null @@ -1,50 +0,0 @@ -Grm. Grammar ::= Header ";" Abstract ";" [Concrete] ; -Hdr. Header ::= "grammar" CId "(" [CId] ")" ; -Abs. Abstract ::= "abstract" "{" [AbsDef] "}" ; -Cnc. Concrete ::= "concrete" CId "{" [CncDef] "}" ; - -Fun. AbsDef ::= CId ":" Type "=" Exp ; ---AFl. AbsDef ::= "%" CId "=" String ; -- flag -Lin. CncDef ::= CId "=" Term ; ---CFl. CncDef ::= "%" CId "=" String ; -- flag - -Typ. Type ::= [CId] "->" CId ; -Tr. Exp ::= "(" Atom [Exp] ")" ; -AC. Atom ::= CId ; -AS. Atom ::= String ; -AI. Atom ::= Integer ; -AF. Atom ::= Double ; -AM. Atom ::= "?" ; -trA. Exp ::= Atom ; -define trA a = Tr a [] ; - -R. Term ::= "[" [Term] "]" ; -- record/table -P. Term ::= "(" Term "!" Term ")" ; -- projection/selection -S. Term ::= "(" [Term] ")" ; -- sequence with ++ -K. Term ::= Tokn ; -- token -V. Term ::= "$" Integer ; -- argument -C. Term ::= Integer ; -- parameter value/label -F. Term ::= CId ; -- global constant -FV. Term ::= "[|" [Term] "|]" ; -- free variation -W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table -RP. Term ::= "(" Term "@" Term ")"; -- record parameter alias -TM. Term ::= "?" ; -- lin of metavariable - -L. Term ::= "(" CId "->" Term ")" ; -- lambda abstracted table -BV. Term ::= "#" CId ; -- lambda-bound variable - -KS. Tokn ::= String ; -KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; -Var. Variant ::= [String] "/" [String] ; - - -terminator Concrete ";" ; -terminator AbsDef ";" ; -terminator CncDef ";" ; -separator CId "," ; -separator Term "," ; -terminator Exp "" ; -terminator String "" ; -separator Variant "," ; - -token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; diff --git a/src/GF/GFCC/doc/old-gfcc.txt b/src/GF/GFCC/doc/old-gfcc.txt deleted file mode 100644 index 6ffd9bd64..000000000 --- a/src/GF/GFCC/doc/old-gfcc.txt +++ /dev/null @@ -1,656 +0,0 @@ -The GFCC Grammar Format -Aarne Ranta -October 19, 2006 - -Author's address: -[``http://www.cs.chalmers.se/~aarne`` http://www.cs.chalmers.se/~aarne] - -% to compile: txt2tags -thtml --toc gfcc.txt - -History: -- 19 Oct: translation of lincats, new figures on C++ -- 3 Oct 2006: first version - - -==What is GFCC== - -GFCC is a low-level format for GF grammars. Its aim is to contain the minimum -that is needed to process GF grammars at runtime. This minimality has three -advantages: -- compact grammar files and run-time objects -- time and space efficient processing -- simple definition of interpreters - - -The idea is that all embedded GF applications are compiled to GFCC. -The GF system would be primarily used as a compiler and as a grammar -development tool. - -Since GFCC is implemented in BNFC, a parser of the format is readily -available for C, C++, Haskell, Java, and OCaml. Also an XML -representation is generated in BNFC. A -[reference implementation ../] -of linearization and some other functions has been written in Haskell. - - -==GFCC vs. GFC== - -GFCC is aimed to replace GFC as the run-time grammar format. GFC was designed -to be a run-time format, but also to -support separate compilation of grammars, i.e. -to store the results of compiling -individual GF modules. But this means that GFC has to contain extra information, -such as type annotations, which is only needed in compilation and not at -run-time. In particular, the pattern matching syntax and semantics of GFC is -complex and therefore difficult to implement in new platforms. - -The main differences of GFCC compared with GFC can be summarized as follows: -- there are no modules, and therefore no qualified names -- a GFCC grammar is multilingual, and consists of a common abstract syntax - together with one concrete syntax per language -- records and tables are replaced by arrays -- record labels and parameter values are replaced by integers -- record projection and table selection are replaced by array indexing -- there is (so far) no support for dependent types or higher-order abstract - syntax (which would be easy to add, but make interpreters much more difficult - to write) - - -Here is an example of a GF grammar, consisting of three modules, -as translated to GFCC. The representations are aligned, with the exceptions -due to the alphabetical sorting of GFCC grammars. -``` - grammar Ex(Eng,Swe); - -abstract Ex = { abstract { - cat - S ; NP ; VP ; - fun - Pred : NP -> VP -> S ; Pred : NP,VP -> S = (Pred); - She, They : NP ; She : -> NP = (She); - Sleep : VP ; Sleep : -> VP = (Sleep); - They : -> NP = (They); -} } ; - -concrete Eng of Ex = { concrete Eng { - lincat - S = {s : Str} ; - NP = {s : Str ; n : Num} ; - VP = {s : Num => Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = { Pred = [(($0!1),(($1!0)!($0!0)))]; - s = np.s ++ vp.s ! np.n} ; - She = {s = "she" ; n = Sg} ; She = [0, "she"]; - They = {s = "they" ; n = Pl} ; - Sleep = {s = table { Sleep = [("sleep" + ["s",""])]; - Sg => "sleeps" ; - Pl => "sleep" They = [1, "they"]; - } } ; - } ; -} - -concrete Swe of Ex = { concrete Swe { - lincat - S = {s : Str} ; - NP = {s : Str} ; - VP = {s : Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = { Pred = [(($0!0),($1!0))]; - s = np.s ++ vp.s} ; - She = {s = "hon"} ; She = ["hon"]; - They = {s = "de"} ; They = ["de"]; - Sleep = {s = "sover"} ; Sleep = ["sover"]; -} } ; -``` - -==The syntax of GFCC files== - -===Top level=== - -A grammar has a header telling the name of the abstract syntax -(often specifying an application domain), and the names of -the concrete languages. The abstract syntax and the concrete -syntaxes themselves follow. -``` - Grammar ::= Header ";" Abstract ";" [Concrete] ; - Header ::= "grammar" CId "(" [CId] ")" ; - Abstract ::= "abstract" "{" [AbsDef] "}" ; - Concrete ::= "concrete" CId "{" [CncDef] "}" ; -``` -Abstract syntax judgements give typings and semantic definitions. -Concrete syntax judgements give linearizations. -``` - AbsDef ::= CId ":" Type "=" Exp ; - CncDef ::= CId "=" Term ; -``` -Also flags are possible, local to each "module" (i.e. abstract and concretes). -``` - AbsDef ::= "%" CId "=" String ; - CncDef ::= "%" CId "=" String ; -``` -For the run-time system, the reference implementation in Haskell -uses a structure that gives efficient look-up: -``` - data GFCC = GFCC { - absname :: CId , - cncnames :: [CId] , - abstract :: Abstr , - concretes :: Map CId Concr - } - - data Abstr = Abstr { - funs :: Map CId Type, -- find the type of a fun - cats :: Map CId [CId] -- find the funs giving a cat - } - - type Concr = Map CId Term -``` - - -===Abstract syntax=== - -Types are first-order function types built from -category symbols. Syntax trees (``Exp``) are -rose trees with the head (``Atom``) either a function -constant, a metavariable, or a string, integer, or float -literal. -``` - Type ::= [CId] "->" CId ; - Exp ::= "(" Atom [Exp] ")" ; - Atom ::= CId ; -- function constant - Atom ::= "?" ; -- metavariable - Atom ::= String ; -- string literal - Atom ::= Integer ; -- integer literal - Atom ::= Double ; -- float literal -``` - - -===Concrete syntax=== - -Linearization terms (``Term``) are built as follows. -Constructor names are shown to make the later code -examples readable. -``` - R. Term ::= "[" [Term] "]" ; -- array - P. Term ::= "(" Term "!" Term ")" ; -- access to indexed field - S. Term ::= "(" [Term] ")" ; -- sequence with ++ - K. Term ::= Tokn ; -- token - V. Term ::= "$" Integer ; -- argument - C. Term ::= Integer ; -- array index - FV. Term ::= "[|" [Term] "|]" ; -- free variation - TM. Term ::= "?" ; -- linearization of metavariable -``` -Tokens are strings or (maybe obsolescent) prefix-dependent -variant lists. -``` - KS. Tokn ::= String ; - KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; - Var. Variant ::= [String] "/" [String] ; -``` -Three special forms of terms are introduced by the compiler -as optimizations. They can in principle be eliminated, but -their presence makes grammars much more compact. Their semantics -will be explained in a later section. -``` - F. Term ::= CId ; -- global constant - W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table - RP. Term ::= "(" Term "@" Term ")"; -- record parameter alias -``` -Identifiers are like ``Ident`` in GF and GFC, except that -the compiler produces constants prefixed with ``_`` in -the common subterm elimination optimization. -``` - token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; -``` - - -==The semantics of concrete syntax terms== - -===Linearization and realization=== - -The linearization algorithm is essentially the same as in -GFC: a tree is linearized by evaluating its linearization term -in the environment of the linearizations of the subtrees. -Literal atoms are linearized in the obvious way. -The function also needs to know the language (i.e. concrete syntax) -in which linearization is performed. -``` - linExp :: GFCC -> CId -> Exp -> Term - linExp mcfg lang tree@(Tr at trees) = case at of - AC fun -> comp (Prelude.map lin trees) $ look fun - AS s -> R [kks (show s)] -- quoted - AI i -> R [kks (show i)] - AF d -> R [kks (show d)] - AM -> TM - where - lin = linExp mcfg lang - comp = compute mcfg lang - look = lookLin mcfg lang -``` -The result of linearization is usually a record, which is realized as -a string using the following algorithm. -``` - realize :: Term -> String - realize trm = case trm of - R (t:_) -> realize t - S ss -> unwords $ Prelude.map realize ss - K (KS s) -> s - K (KP s _) -> unwords s ---- prefix choice TODO - W s t -> s ++ realize t - FV (t:_) -> realize t - TM -> "?" -``` -Since the order of record fields is not necessarily -the same as in GF source, -this realization does not work securely for -categories whose lincats more than one field. - - -===Term evaluation=== - -Evaluation follows call-by-value order, with two environments -needed: -- the grammar (a concrete syntax) to give the global constants -- an array of terms to give the subtree linearizations - - -The code is presented in one-level pattern matching, to -enable reimplementations in languages that do not permit -deep patterns (such as Java and C++). -``` -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute mcfg lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - RP i t -> RP (comp i) (comp t) - W s t -> W s (comp t) - R ts -> R $ Prelude.map comp ts - V i -> idx args (fromInteger i) -- already computed - F c -> comp $ look c -- not computed (if contains V) - FV ts -> FV $ Prelude.map comp ts - S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts - _ -> trm - - look = lookLin mcfg lang - - idx xs i = xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ Prelude.map (proj r) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> fromInteger i - RP p _ -> getIndex p - TM -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i - TM -> TM - _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t -``` - -===The special term constructors=== - -The three forms introduced by the compiler may a need special -explanation. - -Global constants -``` - Term ::= CId ; -``` -are shorthands for complex terms. They are produced by the -compiler by (iterated) common subexpression elimination. -They are often more powerful than hand-devised code sharing in the source -code. They could be computed off-line by replacing each identifier by -its definition. - -Prefix-suffix tables -``` - Term ::= "(" String "+" Term ")" ; -``` -represent tables of word forms divided to the longest common prefix -and its array of suffixes. In the example grammar above, we have -``` - Sleep = [("sleep" + ["s",""])] -``` -which in fact is equal to the array of full forms -``` - ["sleeps", "sleep"] -``` -The power of this construction comes from the fact that suffix sets -tend to be repeated in a language, and can therefore be collected -by common subexpression elimination. It is this technique that -explains the used syntax rather than the more accurate -``` - "(" String "+" [String] ")" -``` -since we want the suffix part to be a ``Term`` for the optimization to -take effect. - -The most curious construct of GFCC is the parameter array alias, -``` - Term ::= "(" Term "@" Term ")"; -``` -This form is used as the value of parameter records, such as the type -``` - {n : Number ; p : Person} -``` -The problem with parameter records is their double role. -They can be used like parameter values, as indices in selection, -``` - VP.s ! {n = Sg ; p = P3} -``` -but also as records, from which parameters can be projected: -``` - {n = Sg ; p = P3}.n -``` -Whichever use is selected as primary, a prohibitively complex -case expression must be generated at compilation to GFCC to get the -other use. The adopted -solution is to generate a pair containing both a parameter value index -and an array of indices of record fields. For instance, if we have -``` - param Number = Sg | Pl ; Person = P1 | P2 | P3 ; -``` -we get the encoding -``` - {n = Sg ; p = P3} ---> (2 @ [0,2]) -``` -The GFCC computation rules are essentially -``` - (t ! (i @ _)) = (t ! i) - ((_ @ r) ! j) =(r ! j) -``` - - -==Compiling to GFCC== - -Compilation to GFCC is performed by the GF grammar compiler, and -GFCC interpreters need not know what it does. For grammar writers, -however, it might be interesting to know what happens to the grammars -in the process. - -The compilation phases are the following -+ translate GF source to GFC, as always in GF -+ undo GFC back-end optimizations -+ perform the ``values`` optimization to normalize tables -+ create a symbol table mapping the GFC parameter and record types to - fixed-size arrays, and parameter values and record labels to integers -+ traverse the linearization rules replacing parameters and labels by integers -+ reorganize the created GFC grammar so that it has just one abstract syntax - and one concrete syntax per language -+ apply UTF8 encoding to the grammar, if not yet applied (this is told by the - ``coding`` flag) -+ translate the GFC syntax tree to a GFCC syntax tree, using a simple - compositional mapping -+ perform the word-suffix optimization on GFCC linearization terms -+ perform subexpression elimination on each concrete syntax module -+ print out the GFCC code - - -Notice that a major part of the compilation is done within GFC, so that -GFC-related tasks (such as parser generation) could be performed by -using the old algorithms. - - -===Problems in GFCC compilation=== - -Two major problems had to be solved in compiling GFC to GFCC: -- consistent order of tables and records, to permit the array translation -- run-time variables in complex parameter values. - - -The current implementation is still experimental and may fail -to generate correct code. Any errors remaining are likely to be -related to the two problems just mentioned. - -The order problem is solved in different ways for tables and records. -For tables, the ``values`` optimization of GFC already manages to -maintain a canonical order. But this order can be destroyed by the -``share`` optimization. To make sure that GFCC compilation works properly, -it is safest to recompile the GF grammar by using the ``values`` -optimization flag. - -Records can be canonically ordered by sorting them by labels. -In fact, this was done in connection of the GFCC work as a part -of the GFC generation, to guarantee consistency. This means that -e.g. the ``s`` field will in general no longer appear as the first -field, even if it does so in the GF source code. But relying on the -order of fields in a labelled record would be misplaced anyway. - -The canonical form of records is further complicated by lock fields, -i.e. dummy fields of form ``lock_C = <>``, which are added to grammar -libraries to force intensionality of linearization types. The problem -is that the absence of a lock field only generates a warning, not -an error. Therefore a GFC grammar can contain objects of the same -type with and without a lock field. This problem was solved in GFCC -generation by just removing all lock fields (defined as fields whose -type is the empty record type). This has the further advantage of -(slightly) reducing the grammar size. More importantly, it is safe -to remove lock fields, because they are never used in computation, -and because intensional types are only needed in grammars reused -as libraries, not in grammars used at runtime. - -While the order problem is rather bureaucratic in nature, run-time -variables are an interesting problem. They arise in the presence -of complex parameter values, created by argument-taking constructors -and parameter records. To give an example, consider the GF parameter -type system -``` - Number = Sg | Pl ; - Person = P1 | P2 | P3 ; - Agr = Ag Number Person ; -``` -The values can be translated to integers in the expected way, -``` - Sg = 0, Pl = 1 - P1 = 0, P2 = 1, P3 = 2 - Ag Sg P1 = 0, Ag Sg P2 = 1, Ag Sg P3 = 2, - Ag Pl P1 = 3, Ag Pl P2 = 4, Ag Pl P3 = 5 -``` -However, an argument of ``Agr`` can be a run-time variable, as in -``` - Ag np.n P3 -``` -This expression must first be translated to a case expression, -``` - case np.n of { - 0 => 2 ; - 1 => 5 - } -``` -which can then be translated to the GFCC term -``` - ([2,5] ! ($0 ! $1)) -``` -assuming that the variable ``np`` is the first argument and that its -``Number`` field is the second in the record. - -This transformation of course has to be performed recursively, since -there can be several run-time variables in a parameter value: -``` - Ag np.n np.p -``` -A similar transformation would be possible to deal with the double -role of parameter records discussed above. Thus the type -``` - RNP = {n : Number ; p : Person} -``` -could be uniformly translated into the set ``{0,1,2,3,4,5}`` -as ``Agr`` above. Selections would be simple instances of indexing. -But any projection from the record should be translated into -a case expression, -``` - rnp.n ===> - case rnp of { - 0 => 0 ; - 1 => 0 ; - 2 => 0 ; - 3 => 1 ; - 4 => 1 ; - 5 => 1 - } -``` -To avoid the code bloat resulting from this, we chose the alias representation -which is easy enough to deal with in interpreters. - - -===The representation of linearization types=== - -Linearization types (``lincat``) are not needed when generating with -GFCC, but they have been added to enable parser generation directly from -GFCC. The linearization type definitions are shown as a part of the -concrete syntax, by using terms to represent types. Here is the table -showing how different linearization types are encoded. -``` - P* = size(P) -- parameter type - {_ : I ; __ : R}* = (I* @ R*) -- record of parameters - {r1 : T1 ; ... ; rn : Tn}* = [T1*,...,Tn*] -- other record - (P => T)* = [T* ,...,T*] -- size(P) times - Str* = () -``` -The category symbols are prefixed with two underscores (``__``). -For example, the linearization type ``present/CatEng.NP`` is -translated as follows: -``` - NP = { - a : { -- 6 = 2*3 values - n : {ParamX.Number} ; -- 2 values - p : {ParamX.Person} -- 3 values - } ; - s : {ResEng.Case} => Str -- 3 values - } - - __NP = [(6@[2,3]),[(),(),()]] -``` - - - - -===Running the compiler and the GFCC interpreter=== - -GFCC generation is a part of the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF since September 2006. To invoke the compiler, the flag -``-printer=gfcc`` to the command -``pm = print_multi`` is used. It is wise to recompile the grammar from -source, since previously compiled libraries may not obey the canonical -order of records. To ``strip`` the grammar before -GFCC translation removes unnecessary interface references. -Here is an example, performed in -[example/bronzeage ../../../../../examples/bronzeage]. -``` - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageEng.gf - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageGer.gf - strip - pm -printer=gfcc | wf bronze.gfcc -``` - - - -==The reference interpreter== - -The reference interpreter written in Haskell consists of the following files: -``` - -- source file for BNFC - GFCC.cf -- labelled BNF grammar of gfcc - - -- files generated by BNFC - AbsGFCC.hs -- abstrac syntax of gfcc - ErrM.hs -- error monad used internally - LexGFCC.hs -- lexer of gfcc files - ParGFCC.hs -- parser of gfcc files and syntax trees - PrintGFCC.hs -- printer of gfcc files and syntax trees - - -- hand-written files - DataGFCC.hs -- post-parser grammar creation, linearization and evaluation - GenGFCC.hs -- random and exhaustive generation, generate-and-test parsing - RunGFCC.hs -- main function - a simple command interpreter -``` -It is included in the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF, in the subdirectory [``GF/src/GF/Canon/GFCC`` ../]. - -To compile the interpreter, type -``` - make gfcc -``` -in ``GF/src``. To run it, type -``` - ./gfcc -``` -The available commands are -- ``gr ``: generate a number of random trees in category. - and show their linearizations in all languages -- ``grt ``: generate a number of random trees in category. - and show the trees and their linearizations in all languages -- ``gt ``: generate a number of trees in category from smallest, - and show their linearizations in all languages -- ``gtt ``: generate a number of trees in category from smallest, - and show the trees and their linearizations in all languages -- ``p ``: "parse", i.e. generate trees until match or - until the given number have been generated -- ````: linearize tree in all languages, also showing full records -- ``quit``: terminate the system cleanly - - -==Interpreter in C++== - -A base-line interpreter in C++ has been started. -Its main functionality is random generation of trees and linearization of them. - -Here are some results from running the different interpreters, compared -to running the same grammar in GF, saved in ``.gfcm`` format. -The grammar contains the English, German, and Norwegian -versions of Bronzeage. The experiment was carried out on -Ubuntu Linux laptop with 1.5 GHz Intel centrino processor. - -|| | GF | gfcc(hs) | gfcc++ | -| program size | 7249k | 803k | 113k -| grammar size | 336k | 119k | 119k -| read grammar | 1150ms | 510ms | 100ms -| generate 222 | 9500ms | 450ms | 800ms -| memory | 21M | 10M | 20M - - - -To summarize: -- going from GF to gfcc is a major win in both code size and efficiency -- going from Haskell to C++ interpreter is not a win yet, because of a space - leak in the C++ version - - - -==Some things to do== - -Interpreter in Java. - -Parsing via MCFG -- the FCFG format can possibly be simplified -- parser grammars should be saved in files to make interpreters easier - - -Hand-written parsers for GFCC grammars to reduce code size -(and efficiency?) of interpreters. - -Binary format and/or file compression of GFCC output. - -Syntax editor based on GFCC. - -Rewriting of resource libraries in order to exploit the -word-suffix sharing better (depth-one tables, as in FM). - - - diff --git a/src/GF/GFCC/doc/syntax.txt b/src/GF/GFCC/doc/syntax.txt deleted file mode 100644 index db8f7c149..000000000 --- a/src/GF/GFCC/doc/syntax.txt +++ /dev/null @@ -1,180 +0,0 @@ -GFCC Syntax - - -==Syntax of GFCC files== - -The parser syntax is very simple, as defined in BNF: -``` - Grm. Grammar ::= [RExp] ; - - App. RExp ::= "(" CId [RExp] ")" ; - AId. RExp ::= CId ; - AInt. RExp ::= Integer ; - AStr. RExp ::= String ; - AFlt. RExp ::= Double ; - AMet. RExp ::= "?" ; - - terminator RExp "" ; - - token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; -``` -While a parser and a printer can be generated for many languages -from this grammar by using the BNF Converter, a parser is also -easy to write by hand using recursive descent. - - -==Syntax of well-formed GFCC code== - -Here is a summary of well-formed syntax, -with a comment on the semantics of each construction. -``` - Grammar ::= - ("grammar" CId CId*) -- abstract syntax name and concrete syntax names - "(" "flags" Flag* ")" -- global and abstract flags - "(" "abstract" Abstract ")" -- abstract syntax - "(" "concrete" Concrete* ")" -- concrete syntaxes - - Abstract ::= - "(" "fun" FunDef* ")" -- function definitions - "(" "cat" CatDef* ")" -- category definitions - - Concrete ::= - "(" CId -- language name - "flags" Flag* -- concrete flags - "lin" LinDef* -- linearization rules - "oper" LinDef* -- operations (macros) - "lincat" LinDef* -- linearization type definitions - "lindef" LinDef* -- linearization default definitions - "printname" LinDef* -- printname definitions - "param" LinDef* -- lincats with labels and parameter value names - ")" - - Flag ::= "(" CId String ")" -- flag and value - FunDef ::= "(" CId Type Exp ")" -- function, type, and definition - CatDef ::= "(" CId Hypo* ")" -- category and context - LinDef ::= "(" CId Term ")" -- function and definition - - Type ::= - "(" CId -- value category - "(" "H" Hypo* ")" -- argument context - "(" "X" Exp* ")" ")" -- arguments (of dependent value type) - - Exp ::= - "(" CId -- function - "(" "B" CId* ")" -- bindings - "(" "X" Exp* ")" ")" -- arguments - | CId -- variable - | "?" -- metavariable - | "(" "Eq" Equation* ")" -- group of pattern equations - | Integer -- integer literal (non-negative) - | Float -- floating-point literal (non-negative) - | String -- string literal (in double quotes) - - Hypo ::= "(" CId Type ")" -- variable and type - - Equation ::= "(" "E" Exp Exp* ")" -- value and pattern list - - Term ::= - "(" "R" Term* ")" -- array (record or table) - | "(" "S" Term* ")" -- concatenated sequence - | "(" "FV" Term* ")" -- free variant list - | "(" "P" Term Term ")" -- access to index (projection or selection) - | "(" "W" String Term ")" -- token prefix with suffix list - | "(" "A" Integer ")" -- pointer to subtree - | String -- token (in double quotes) - | Integer -- index in array - | CId -- macro constant - | "?" -- metavariable -``` - - -==GFCC interpreter== - -The first phase in interpreting GFCC is to parse a GFCC file and -build an internal abstract syntax representation, as specified -in the previous section. - -With this representation, linearization can be performed by -a straightforward function from expressions (``Exp``) to terms -(``Term``). All expressions except groups of pattern equations -can be linearized. - -Here is a reference Haskell implementation of linearization: -``` - linExp :: GFCC -> CId -> Exp -> Term - linExp gfcc lang tree@(DTr _ at trees) = case at of - AC fun -> comp (map lin trees) $ look fun - AS s -> R [K (show s)] -- quoted - AI i -> R [K (show i)] - AF d -> R [K (show d)] - AM -> TM - where - lin = linExp gfcc lang - comp = compute gfcc lang - look = lookLin gfcc lang -``` -TODO: bindings must be supported. - -Terms resulting from linearization are evaluated in -call-by-value order, with two environments needed: -- the grammar (a concrete syntax) to give the global constants -- an array of terms to give the subtree linearizations - - -The Haskell implementation works as follows: -``` -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute gfcc lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - W s t -> W s (comp t) - R ts -> R $ map comp ts - V i -> idx args (fromInteger i) -- already computed - F c -> comp $ look c -- not computed (if contains V) - FV ts -> FV $ Prelude.map comp ts - S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts - _ -> trm - - look = lookOper gfcc lang - - idx xs i = xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ Prelude.map (proj r) ts - (FV ts, _ ) -> FV $ Prelude.map (\t -> proj t p) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> fromInteger i - RP p _ -> getIndex p - TM -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i - TM -> TM - _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t -``` -The result of linearization is usually a record, which is realized as -a string using the following algorithm. -``` - realize :: Term -> String - realize trm = case trm of - R (t:_) -> realize t - S ss -> unwords $ map realize ss - K s -> s - W s t -> s ++ realize t - FV (t:_) -> realize t -- TODO: all variants - TM -> "?" -``` -Notice that realization always picks the first field of a record. -If a linearization type has more than one field, the first field -does not necessarily contain the desired string. -Also notice that the order of record fields in GFCC is not necessarily -the same as in GF source. diff --git a/src/GF/GFModes.hs b/src/GF/GFModes.hs deleted file mode 100644 index faab3cede..000000000 --- a/src/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/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs deleted file mode 100644 index 57e21f1dd..000000000 --- a/src/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/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs deleted file mode 100644 index c03783a52..000000000 --- a/src/GF/Grammar/Abstract.hs +++ /dev/null @@ -1,38 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Abstract --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.Abstract ( - -module GF.Grammar.Grammar, -module GF.Grammar.Values, -module GF.Grammar.Macros, -module GF.Infra.Ident, -module GF.Grammar.MMacros, -module GF.Grammar.PrGrammar, - -Grammar - - ) where - -import GF.Grammar.Grammar -import GF.Grammar.Values -import GF.Grammar.Macros -import GF.Infra.Ident -import GF.Grammar.MMacros -import GF.Grammar.PrGrammar - -type Grammar = SourceGrammar --- - - - diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs deleted file mode 100644 index 530184c3e..000000000 --- a/src/GF/Grammar/AppPredefined.hs +++ /dev/null @@ -1,159 +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.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Grammar.PrGrammar (prt,prt_,prtBad) ----- import PGrammar (pTrm) - --- 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 typeType - "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",typeTok] typeTok - "drop" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok - "eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool") - "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool") - "eqStr" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool") - "length" -> return $ mkFunType [typeTok] (cnPredef "Int") - "occur" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool") - "occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool") - "plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int") ----- "read" -> (P : Type) -> Tok -> P - "show" -> return $ mkProd -- (P : PType) -> P -> Tok - ([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[]) - "toStr" -> return $ mkProd -- (L : Type) -> L -> Str - ([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[]) - "mapStr" -> - let ty = zIdent "L" in - return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L - ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[]) - "take" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok - "tk" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok - _ -> prtBad "unknown in Predef:" c -typPredefined c = prtBad "unknown in Predef:" c - -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 - _ -> Cn $ IC s --- - where - mkCn t = case t of - Vr i -> Cn 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 - TSh _ ((_,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,typeTok] -> 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/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs deleted file mode 100644 index c76058cc2..000000000 --- a/src/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/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs deleted file mode 100644 index 95fdce611..000000000 --- a/src/GF/Grammar/Grammar.hs +++ /dev/null @@ -1,244 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Grammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:20 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- GF source abstract syntax used internally in compilation. --- --- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003 ------------------------------------------------------------------------------ - -module GF.Grammar.Grammar (SourceGrammar, - SourceModInfo, - SourceModule, - SourceAbs, - SourceRes, - SourceCnc, - Info(..), - PValues, - Perh, - MPr, - Type, - Cat, - Fun, - QIdent, - Term(..), - Patt(..), - TInfo(..), - Label(..), - MetaSymb(..), - Decl, - Context, - Equation, - Labelling, - Assign, - Case, - Cases, - LocalDef, - Param, - Altern, - Substitution, - Branch(..), - Con, - Trm, - wildPatt, - varLabel - ) where - -import GF.Data.Str -import GF.Infra.Ident -import GF.Infra.Option --- -import GF.Infra.Modules - -import GF.Data.Operations - --- | grammar as presented to the compiler -type SourceGrammar = MGrammar Ident Option Info - -type SourceModInfo = ModInfo Ident Option Info - -type SourceModule = (Ident, SourceModInfo) - -type SourceAbs = Module Ident Option Info -type SourceRes = Module Ident Option Info -type SourceCnc = Module Ident Option Info - --- this is created in CheckGrammar, and so are Val and PVal -type PValues = [Term] - --- | the constructors are judgements in --- --- - abstract syntax (/ABS/) --- --- - resource (/RES/) --- --- - concrete syntax (/CNC/) --- --- and indirection to module (/INDIR/) -data Info = --- judgements in abstract syntax - AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId' - | AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical - | AbsTrans Term -- ^ (/ABS/) - --- judgements in resource - | ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/) - | ResValue (Perh (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup - | ResOper (Perh Type) (Perh Term) -- ^ (/RES/) - - | ResOverload [(Type,Term)] -- ^ (/RES/) - --- judgements in concrete syntax - | CncCat (Perh Type) (Perh Term) MPr -- ^ (/CNC/) lindef ini'zed, - | CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- (/CNC/) type info added at 'TC' - --- indirection to module Ident - | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical - deriving (Read, Show) - --- | to express indirection to other module -type Perh a = Perhaps a Ident - --- | printname -type MPr = Perhaps Term Ident - -type Type = Term -type Cat = QIdent -type Fun = QIdent - -type QIdent = (Ident,Ident) - -data Term = - Vr Ident -- ^ variable - | Cn Ident -- ^ constant - | Con Ident -- ^ constructor - | EData -- ^ to mark in definition that a fun is a constructor - | Sort String -- ^ basic 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 ; ...}@ - | TSh TInfo [Cases] -- ^ table with disjunctive patters (only back end opt) - | V Type [Term] -- ^ table given as 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@ - - | Alias Ident Type Term -- ^ constant and its definition, used in inlining - - | Q Ident Ident -- ^ qualified constant from a package - | QC Ident Ident -- ^ qualified constructor from a package - - | C Term Term -- ^ concatenation: @s ++ t@ - | Glue Term Term -- ^ agglutination: @s + t@ - - | EPatt Patt -- ^ pattern (in macro definition): # p - | EPattType Term -- ^ pattern type: pattern T - - | FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@ - - | Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@ - | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@ --- --- /below this, the last three constructors are obsolete/ - | LiT Ident -- ^ linearization type - | Ready Str -- ^ result of compiling; not to be parsed ... - | Computed Term -- ^ result of computing: not to be reopened nor parsed - - deriving (Read, Show, Eq, Ord) - -data Patt = - PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ - | PP Ident Ident [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ - | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete - | PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract - | PInt Integer -- ^ integer literal pattern: @12@ -- only abstract - | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract - | PT Type Patt -- ^ type-annotated pattern - - | PVal Type Int -- ^ parameter value number: @T # i# - - | 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 [Char] -- ^ character list: ["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 annontated, 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) - -newtype MetaSymb = MetaSymb Int deriving (Read, Show, Eq, Ord) - -type Decl = (Ident,Term) -- (x:A) (_:A) A -type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) -type Equation = ([Patt],Term) - -type Labelling = (Label, Term) -type Assign = (Label, (Maybe Type, Term)) -type Case = (Patt, Term) -type Cases = ([Patt], Term) -type LocalDef = (Ident, (Maybe Type, Term)) - -type Param = (Ident, Context) -type Altern = (Term, [(Term, Term)]) - -type Substitution = [(Ident, Term)] - --- | 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 = PV wildIdent - -type Trm = Term diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs deleted file mode 100644 index 960b12983..000000000 --- a/src/GF/Grammar/Lockfield.hs +++ /dev/null @@ -1,46 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Lockfield --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- Creating and using lock fields in reused resource grammars. --- --- AR 8\/2\/2005 detached from 'compile/MkResource' ------------------------------------------------------------------------------ - -module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Grammar.PrGrammar - -import GF.Data.Operations - -lockRecType :: Ident -> Type -> Err Type -lockRecType c t@(RecType rs) = - let lab = lockLabel c in - return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"] - then t --- don't add an extra copy of lock field, nor predef cats - else RecType (rs ++ [(lockLabel c, RecType [])]) -lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])] - -unlockRecord :: Ident -> Term -> Err Term -unlockRecord c ft = do - let (xs,t) = termFormCnc ft - t' <- plusRecord t $ R [(lockLabel c, (Just (RecType []),R []))] - return $ mkAbs xs t' - -lockLabel :: Ident -> Label -lockLabel c = LIdent $ "lock_" ++ prt c ---- - -isLockLabel :: Label -> Bool -isLockLabel l = case l of - LIdent c -> take 5 c == "lock_" - _ -> False diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs deleted file mode 100644 index 5bd4c1e41..000000000 --- a/src/GF/Grammar/LookAbs.hs +++ /dev/null @@ -1,196 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : LookAbs --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/28 16:42:48 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.LookAbs (GFCGrammar, - lookupAbsDef, - lookupFunType, - lookupCatContext, - lookupTransfer, - isPrimitiveFun, - lookupRef, - refsForType, - funRulesOf, - hasHOAS, - allCatsOf, - allBindCatsOf, - funsForType, - funsOnType, - funsOnTypeFs, - allDefs, - lookupFunTypeSrc, - lookupCatContextSrc - ) where - -import GF.Data.Operations -import qualified GF.Canon.GFC as C -import GF.Grammar.Abstract -import GF.Infra.Ident - -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 - 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 - _ -> 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 - 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 - _ -> prtBad "unknown category" c - _ -> Bad $ prt m +++ "is not an abstract module" diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs deleted file mode 100644 index 81a62decf..000000000 --- a/src/GF/Grammar/Lookup.hs +++ /dev/null @@ -1,275 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Lookup --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/27 13:21:53 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.15 $ --- --- Lookup in source (concrete and resource) when compiling. --- --- lookup in resource and concrete in compiling; for abstract, use 'Look' ------------------------------------------------------------------------------ - -module GF.Grammar.Lookup ( - lookupResDef, - lookupResDefKind, - lookupResType, - lookupOverload, - lookupParams, - lookupParamValues, - lookupFirstTag, - lookupValueIndex, - lookupIndexValue, - allOrigInfos, - allParamValues, - lookupAbsDef, - lookupLincat, - opersForType, - linTypeInt - ) where - -import GF.Data.Operations -import GF.Grammar.Abstract -import GF.Infra.Modules -import GF.Grammar.Lockfield - -import Data.List (nub,sortBy) -import Control.Monad - --- whether lock fields are added in reuse -lock c = lockRecType c -- return -unlock c = unlockRecord c -- return - -lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term -lookupResDef gr m c = liftM fst $ lookupResDefKind gr m c - --- 0 = oper, 1 = lin, 2 = canonical. v > 0 means: no need to be recomputed -lookupResDefKind :: SourceGrammar -> Ident -> Ident -> Err (Term,Int) -lookupResDefKind gr m c = look True m c where - look isTop m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResOper _ (Yes t) -> return (qualifAnnot m t, 0) - ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c - ---- else prtBad "cannot find in exts" c - - CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty - CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType - CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr - - CncFun _ (Yes tr) _ -> liftM (flip (,) 1) $ unlock c tr - - AnyInd _ n -> look False n c - ResParam _ -> return (QC m c,2) - ResValue _ -> return (QC m c,2) - _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" - lookExt m c = - checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)]) - -lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type -lookupResType gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResOper (Yes t) _ -> return $ qualifAnnot m t - ResOper (May n) _ -> lookupResType gr n c - - -- used in reused concrete - CncCat _ _ _ -> return typeType - CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do - val' <- lock cat val - return $ mkProd (cont, val', []) - CncFun _ _ _ -> lookFunType m m c - AnyInd _ n -> lookupResType gr n c - ResParam _ -> return $ typePType - ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t - _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" - where - lookFunType e m c = do - a <- abstractOfConcrete gr m - lookFun e m c a - lookFun e m c a = do - mu <- lookupModMod gr a - info <- lookupIdentInfo mu c - case info of - AbsFun (Yes ty) _ -> return $ redirectTerm e ty - AbsCat _ _ -> return typeType - AnyInd _ n -> lookFun e m c n - _ -> prtBad "cannot find type of reused function" c - -lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] -lookupOverload gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResOverload tysts -> - return [(map snd args,(val,tr)) | - (ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] - - AnyInd _ n -> lookupOverload gr n c - _ -> Bad $ prt c +++ "is not an overloaded operation" - _ -> Bad $ prt m +++ "is not a resource" - -lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info -lookupOrigInfo gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - AnyInd _ n -> lookupOrigInfo gr n c - i -> return i - _ -> Bad $ prt m +++ "is not run-time module" - -lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues) -lookupParams gr = look True where - look isTop m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResParam (Yes psm) -> return psm - - AnyInd _ n -> look False n c - _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" - lookExt m c = - checks [look False n c | n <- allExtensions gr m] - -lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] -lookupParamValues gr m c = do - (ps,mpv) <- lookupParams gr m c - case mpv of - Just ts -> return ts - _ -> liftM concat $ mapM mkPar ps - where - mkPar (f,co) = do - vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co - return $ map (mkApp (QC m f)) vs - -lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term -lookupFirstTag gr m c = do - vs <- lookupParamValues gr m c - case vs of - v:_ -> return v - _ -> prtBad "no parameter values given to type" c - -lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term -lookupValueIndex gr ty tr = do - ts <- allParamValues gr ty - case lookup tr $ zip ts [0..] of - Just i -> return $ Val ty i - _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty - -lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term -lookupIndexValue gr ty i = do - ts <- allParamValues gr ty - if i < length ts - then return $ ts !! i - else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty - -allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] -allOrigInfos gr m = errVal [] $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]] - where - look = lookupOrigInfo gr m - -allParamValues :: SourceGrammar -> 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)) - -qualifAnnot :: Ident -> Term -> Term -qualifAnnot _ = id --- Using this we wouldn't have to annotate constants defined in a module itself. --- But things are simpler if we do (cf. Zinc). --- Change Rename.self2status to change this behaviour. - --- we need this for lookup in ResVal -qualifAnnotPar m t = case t of - Cn c -> Q m c - Con c -> QC m c - _ -> composSafeOp (qualifAnnotPar m) t - -lookupAbsDef :: SourceGrammar -> 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 - AbsFun _ (Yes t) -> return $ return t - AnyInd _ n -> lookupAbsDef gr n c - _ -> return Nothing - _ -> Bad $ prt m +++ "is not an abstract module" - -linTypeInt :: Type -linTypeInt = 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)] - -lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type -lookupLincat gr m c | elem c [zIdent "Int"] = return linTypeInt -lookupLincat gr m c | elem c [zIdent "String", zIdent "Float"] = - return defLinType --- ad hoc; not needed? - -lookupLincat gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - CncCat (Yes t) _ _ -> return t - AnyInd _ n -> lookupLincat gr n c - _ -> Bad $ prt c +++ "has no linearization type in" +++ prt m - _ -> Bad $ prt m +++ "is not concrete" - - --- The first type argument is uncomputed, usually a category symbol. --- This is a hack to find implicit (= reused) opers. - -opersForType :: SourceGrammar -> Type -> Type -> [(QIdent,Term)] -opersForType gr orig val = - [((i,f),ty) | (i,m) <- allModMod gr, (f,ty) <- opers i m val] where - opers i m val = - [(f,ty) | - (f,ResOper (Yes ty) _) <- tree2list $ jments m, - Ok valt <- [valTypeCnc ty], - elem valt [val,orig] - ] ++ - let cat = err zIdent snd (valCat orig) in --- ignore module - [(f,ty) | - Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr], - (f, AbsFun (Yes ty0) _) <- tree2list $ jments a, - let ty = redirectTerm i ty0, - Ok valt <- [valCat ty], - cat == snd valt --- - ] diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs deleted file mode 100644 index dd7331685..000000000 --- a/src/GF/Grammar/MMacros.hs +++ /dev/null @@ -1,341 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MMacros --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 12:49:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- some more abstractions on grammars, esp. for Edit ------------------------------------------------------------------------------ - -module GF.Grammar.MMacros where - -import GF.Data.Operations -import GF.Data.Zipper - -import GF.Grammar.Grammar -import GF.Grammar.PrGrammar -import GF.Infra.Ident -import GF.Grammar.Refresh -import GF.Grammar.Values -----import GrammarST -import GF.Grammar.Macros - -import Control.Monad - -nodeTree :: Tree -> TrNode -argsTree :: Tree -> [Tree] - -nodeTree (Tr (n,_)) = n -argsTree (Tr (_,ts)) = ts - -isFocusNode :: TrNode -> Bool -bindsNode :: TrNode -> Binds -atomNode :: TrNode -> Atom -valNode :: TrNode -> Val -constrsNode :: TrNode -> Constraints -metaSubstsNode :: TrNode -> MetaSubst - -isFocusNode (N (_,_,_,_,b)) = b -bindsNode (N (b,_,_,_,_)) = b -atomNode (N (_,a,_,_,_)) = a -valNode (N (_,_,v,_,_)) = v -constrsNode (N (_,_,_,(c,_),_)) = c -metaSubstsNode (N (_,_,_,(_,m),_)) = m - -atomTree :: Tree -> Atom -valTree :: Tree -> Val - -atomTree = atomNode . nodeTree -valTree = valNode . nodeTree - -mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode -mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False) - -type Var = Ident -type Meta = MetaSymb - -metasTree :: Tree -> [Meta] -metasTree = concatMap metasNode . scanTree where - metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n) - -varsTree :: Tree -> [(Var,Val)] -varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t] - -constrsTree :: Tree -> Constraints -constrsTree = constrsNode . nodeTree - -allConstrsTree :: Tree -> Constraints -allConstrsTree = concatMap constrsNode . scanTree - -changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode -changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x) - -changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode -changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x) - -changeAtom :: (Atom -> Atom) -> TrNode -> TrNode -changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x) - --- * on the way to Edit - -uTree :: Tree -uTree = Tr (uNode, []) -- unknown tree - -uNode :: TrNode -uNode = mkNode [] uAtom uVal ([],[]) - - -uAtom :: Atom -uAtom = AtM meta0 - -mAtom :: Atom -mAtom = AtM meta0 - -uVal :: Val -uVal = vClos uExp - -vClos :: Exp -> Val -vClos = VClos [] - -uExp :: Exp -uExp = Meta meta0 - -mExp, mExp0 :: Exp -mExp = Meta meta0 -mExp0 = mExp - -meta2exp :: MetaSymb -> Exp -meta2exp = Meta - -atomC :: Fun -> Atom -atomC = AtC - -funAtom :: Atom -> Err Fun -funAtom a = case a of - AtC f -> return f - _ -> prtBad "not function head" a - -uBoundVar :: Ident -uBoundVar = zIdent "#h" -- used for suppressed bindings - -atomIsMeta :: Atom -> Bool -atomIsMeta atom = case atom of - AtM _ -> True - _ -> False - -getMetaAtom :: Atom -> Err Meta -getMetaAtom a = case a of - AtM m -> return m - _ -> Bad "the active node is not meta" - -cat2val :: Context -> Cat -> Val -cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]] - -val2cat :: Val -> Err Cat -val2cat v = val2exp v >>= valCat - -substTerm :: [Ident] -> Substitution -> Term -> Term -substTerm ss g c = case c of - Vr x -> maybe c id $ lookup x g - App f a -> App (substTerm ss g f) (substTerm ss g a) - Abs x b -> let y = mkFreshVarX ss x in - Abs y (substTerm (y:ss) ((x, Vr y):g) b) - Prod x a b -> let y = mkFreshVarX ss x in - Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b) - _ -> c - -metaSubstExp :: MetaSubst -> [(Meta,Exp)] -metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst] - --- * belong here rather than to computation - -substitute :: [Var] -> Substitution -> Exp -> Err Exp -substitute v s = return . substTerm v s - -alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp --- -alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')] - -alphaFresh :: [Var] -> Exp -> Err Exp -alphaFresh vs = refreshTermN $ maxVarIndex vs - --- | done in a state monad -alphaFreshAll :: [Var] -> [Exp] -> Err [Exp] -alphaFreshAll vs = mapM $ alphaFresh vs - --- | for display -val2exp :: Val -> Err Exp -val2exp = val2expP False - --- | for type checking -val2expSafe :: Val -> Err Exp -val2expSafe = val2expP True - -val2expP :: Bool -> Val -> Err Exp -val2expP safe v = case v of - - VClos g@(_:_) e@(Meta _) -> if safe - then prtBad "unsafe value substitution" v - else substVal g e - VClos g e -> substVal g e - VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c) - VCn c -> return $ qq c - VGen i x -> if safe - then prtBad "unsafe val2exp" v - else return $ vr $ x --- in editing, no alpha conversions presentv - where - substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e) - -isConstVal :: Val -> Bool -isConstVal v = case v of - VApp f c -> isConstVal f && isConstVal c - VCn _ -> True - VClos [] e -> null $ freeVarsExp e - _ -> False --- could be more liberal - -mkProdVal :: Binds -> Val -> Err Val --- -mkProdVal bs v = do - bs' <- mapPairsM val2exp bs - v' <- val2exp v - return $ vClos $ foldr (uncurry Prod) v' bs' - -freeVarsExp :: Exp -> [Ident] -freeVarsExp e = case e of - Vr x -> [x] - App f c -> freeVarsExp f ++ freeVarsExp c - Abs x b -> filter (/=x) (freeVarsExp b) - Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b) - _ -> [] --- thus applies to abstract syntax only - -ident2string :: Ident -> String -ident2string = prIdent - -tree :: (TrNode,[Tree]) -> Tree -tree = Tr - -eqCat :: Cat -> Cat -> Bool -eqCat = (==) - -addBinds :: Binds -> Tree -> Tree -addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts) - -bodyTree :: Tree -> Tree -bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts) - -refreshMetas :: [Meta] -> Exp -> Exp -refreshMetas metas = fst . rms minMeta where - rms meta trm = case trm of - Meta m -> (Meta meta, nextMeta meta) - App f a -> let (f',msf) = rms meta f - (a',msa) = rms msf a - in (App f' a', msa) - Prod x a b -> - let (a',msa) = rms meta a - (b',msb) = rms msa b - in (Prod x a' b', msb) - Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb) - _ -> (trm,meta) - minMeta = int2meta $ - if null metas then 0 else (maximum (map metaSymbInt metas) + 1) - -ref2exp :: [Var] -> Type -> Ref -> Err Exp -ref2exp bounds typ ref = do - cont <- contextOfType typ - xx0 <- mapM (typeSkeleton . snd) cont - let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0] - args = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds] - return $ mkApp ref args - -- no refreshment of metas - --- | invariant: only 'Con' or 'Var' -type Ref = Exp - -fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp -fun2wrap oldvars ((fun,i),typ) exp = do - cont <- contextOfType typ - args <- mapM mkArg (zip [0..] (map snd cont)) - return $ mkApp (qq fun) args - where - mkArg (n,c) = do - cont <- contextOfType c - let vars = mkFreshVars (length cont) oldvars - return $ mkAbs vars $ if n==i then exp else mExp - --- | weak heuristics: sameness of value category -compatType :: Val -> Type -> Bool -compatType v t = errVal True $ do - cat1 <- val2cat v - cat2 <- valCat t - return $ cat1 == cat2 - ---- - -mkJustProd :: Context -> Term -> Term -mkJustProd cont typ = mkProd (cont,typ,[]) - -int2var :: Int -> Ident -int2var = zIdent . ('$':) . show - -meta0 :: Meta -meta0 = int2meta 0 - -termMeta0 :: Term -termMeta0 = Meta meta0 - -identVar :: Term -> Err Ident -identVar (Vr x) = return x -identVar _ = Bad "not a variable" - - --- | light-weight rename for user interaction; also change names of internal vars -qualifTerm :: Ident -> Term -> Term -qualifTerm m = qualif [] where - qualif xs t = case t of - Abs x b -> let x' = chV x in Abs x' $ qualif (x':xs) b - Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b - Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x) - Cn c -> Q m c - Con c -> QC m c - _ -> composSafeOp (qualif xs) t - chV x = string2var $ prIdent x - -string2var :: String -> Ident -string2var s = case s of - c:'_':i -> identV (readIntArg i,[c]) --- - _ -> zIdent s - --- | reindex variables so that they tell nesting depth level -reindexTerm :: Term -> Term -reindexTerm = qualif (0,[]) where - qualif dg@(d,g) t = case t of - Abs x b -> let x' = ind x d in Abs x' $ qualif (d+1, (x,x'):g) b - Prod x a b -> let x' = ind x d in Prod x' (qualif dg a) $ qualif (d+1, (x,x'):g) b - Vr x -> Vr $ look x g - _ -> composSafeOp (qualif dg) t - look x = maybe x id . lookup x --- if x is not in scope it is unchanged - ind x d = identC $ prIdent x ++ "_" ++ show d - - --- this method works for context-free abstract syntax --- and is meant to be used in simple embedded GF applications - -exp2tree :: Exp -> Err Tree -exp2tree e = do - (bs,f,xs) <- termForm e - cont <- case bs of - [] -> return [] - _ -> prtBad "cannot convert bindings in" e - at <- case f of - Q m c -> return $ AtC (m,c) - QC m c -> return $ AtC (m,c) - Meta m -> return $ AtM m - K s -> return $ AtL s - EInt n -> return $ AtI n - EFloat n -> return $ AtF n - _ -> prtBad "cannot convert to atom" f - ts <- mapM exp2tree xs - return $ Tr (N (cont,at,uVal,([],[]),True),ts) diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs deleted file mode 100644 index 58c449901..000000000 --- a/src/GF/Grammar/Macros.hs +++ /dev/null @@ -1,817 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Macros --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 16:38:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.24 $ --- --- Macros for constructing and analysing source code terms. --- --- operations on terms and types not involving lookup in or reference to grammars --- --- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001 ------------------------------------------------------------------------------ - -module GF.Grammar.Macros where - -import GF.Data.Operations -import GF.Data.Str -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.PrGrammar - -import Control.Monad (liftM, liftM2) -import Data.Char (isDigit) - -firstTypeForm :: Type -> Err (Context, Type) -firstTypeForm t = case t of - Prod x a b -> do - (x', val) <- firstTypeForm b - return ((x,a):x',val) - _ -> return ([],t) - -qTypeForm :: Type -> Err (Context, Cat, [Term]) -qTypeForm t = case t of - Prod x a b -> do - (x', cat, args) <- qTypeForm b - return ((x,a):x', cat, args) - App c a -> do - (_,cat, args) <- qTypeForm c - return ([],cat,args ++ [a]) - Q m c -> - return ([],(m,c),[]) - QC m c -> - return ([],(m,c),[]) - _ -> - prtBad "no normal form of type" t - -qq :: QIdent -> Term -qq (m,c) = Q m c - -typeForm :: Type -> Err (Context, Cat, [Term]) -typeForm = qTypeForm ---- no need to distinguish any more - -cPredef :: Ident -cPredef = identC "Predef" - -cnPredef :: String -> Term -cnPredef f = Q cPredef (identC f) - -typeFormCnc :: Type -> Err (Context, Type) -typeFormCnc t = case t of - Prod x a b -> do - (x', v) <- typeFormCnc b - return ((x,a):x',v) - _ -> return ([],t) - -valCat :: Type -> Err Cat -valCat typ = - do (_,cat,_) <- typeForm typ - return cat - -valType :: Type -> Err Type -valType typ = - do (_,cat,xx) <- typeForm typ --- not optimal to do in this way - return $ mkApp (qq cat) xx - -valTypeCnc :: Type -> Err Type -valTypeCnc typ = - do (_,ty) <- typeFormCnc typ - return ty - -typeRawSkeleton :: Type -> Err ([(Int,Type)],Type) -typeRawSkeleton typ = - do (cont,typ) <- typeFormCnc typ - args <- mapM (typeRawSkeleton . snd) cont - return ([(length c, v) | (c,v) <- args], typ) - -type MCat = (Ident,Ident) - -sortMCat :: String -> MCat -sortMCat s = (zIdent "_", zIdent s) - ---- hack for Editing.actCat in empty state -errorCat :: MCat -errorCat = (zIdent "?", zIdent "?") - -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 - _ -> prtBad "no qualified constant" t - -typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) -typeSkeleton typ = do - (cont,val) <- typeRawSkeleton typ - cont' <- mapPairsM getMCat cont - val' <- getMCat val - return (cont',val') - -catSkeleton :: Type -> Err ([MCat],MCat) -catSkeleton typ = - do (args,val) <- typeSkeleton typ - return (map snd args, val) - -funsToAndFrom :: Type -> (MCat, [(MCat,[Int])]) -funsToAndFrom t = errVal undefined $ do --- - (cs,v) <- catSkeleton t - let cis = zip cs [0..] - return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs]) - -typeFormConcrete :: Type -> Err (Context, Type) -typeFormConcrete t = case t of - Prod x a b -> do - (x', typ) <- typeFormConcrete b - return ((x,a):x', typ) - _ -> return ([],t) - -isRecursiveType :: Type -> Bool -isRecursiveType t = errVal False $ do - (cc,c) <- catSkeleton t -- thus recursivity on Cat level - return $ any (== c) cc - -isHigherOrderType :: Type -> Bool -isHigherOrderType t = errVal True $ do -- pessimistic choice - co <- contextOfType t - return $ not $ null [x | (x,Prod _ _ _) <- co] - -contextOfType :: Type -> Err Context -contextOfType typ = case typ of - Prod x a b -> liftM ((x,a):) $ contextOfType b - _ -> return [] - -unComputed :: Term -> Term -unComputed t = case t of - Computed v -> unComputed v - _ -> t --- composSafeOp unComputed t - - -{- ---- defined (better) in compile/PrOld - -stripTerm :: Term -> Term -stripTerm t = case t of - Q _ c -> Cn c - QC _ c -> Cn c - T ti psts -> T ti [(stripPatt p, stripTerm v) | (p,v) <- psts] - _ -> composSafeOp stripTerm t - where - stripPatt p = errVal p $ term2patt $ stripTerm $ patt2term p --} - -computed :: Term -> Term -computed = Computed - -termForm :: Term -> Err ([(Ident)], Term, [Term]) -termForm t = case t of - Abs x b -> - do (x', fun, args) <- termForm b - return (x:x', fun, args) - App c a -> - do (_,fun, args) <- termForm c - return ([],fun,args ++ [a]) - _ -> - return ([],t,[]) - -termFormCnc :: Term -> ([(Ident)], Term) -termFormCnc t = case t of - Abs x b -> (x:xs, t') where (xs,t') = termFormCnc b - _ -> ([],t) - -appForm :: Term -> (Term, [Term]) -appForm t = case t of - App c a -> (fun, args ++ [a]) where (fun, args) = appForm c - _ -> (t,[]) - -varsOfType :: Type -> [Ident] -varsOfType t = case t of - Prod x _ b -> x : varsOfType b - _ -> [] - -mkProdSimple :: Context -> Term -> Term -mkProdSimple c t = mkProd (c,t,[]) - -mkProd :: (Context, Term, [Term]) -> Term -mkProd ([],typ,args) = mkApp typ args -mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args)) - -mkTerm :: ([(Ident)], Term, [Term]) -> Term -mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa) - -mkApp :: Term -> [Term] -> Term -mkApp = foldl App - -mkAbs :: [Ident] -> Term -> Term -mkAbs xx t = foldr Abs t xx - -appCons :: Ident -> [Term] -> Term -appCons = mkApp . Cn - -appc :: String -> [Term] -> Term -appc = appCons . zIdent - -appqc :: String -> String -> [Term] -> Term -appqc q c = mkApp (Q (zIdent q) (zIdent c)) - -mkLet :: [LocalDef] -> Term -> Term -mkLet defs t = foldr Let t defs - -mkLetUntyped :: Context -> Term -> Term -mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (x,t) <- defs] - -isVariable :: Term -> Bool -isVariable (Vr _ ) = True -isVariable _ = False - -eqIdent :: Ident -> Ident -> Bool -eqIdent = (==) - -zIdent :: String -> Ident -zIdent s = identC s - -uType :: Type -uType = Cn (zIdent "UndefinedType") - -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 - -mkAssign :: [(Label,Term)] -> [Assign] -mkAssign lts = [assign l t | (l,t) <- lts] - -zipAssign :: [Label] -> [Term] -> [Assign] -zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] - -ident2label :: Ident -> Label -ident2label c = LIdent (prIdent c) - -label2ident :: Label -> Ident -label2ident = identC . prLabel - -prLabel :: Label -> String -prLabel = prt - -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) - -mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term -mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs] - -mkRecord :: (Int -> Label) -> [Term] -> Term -mkRecord = mkRecordN 0 - -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 - -record2subst :: Term -> Err Substitution -record2subst t = case t of - R fs -> return [(zIdent x, t) | (LIdent x,(_,t)) <- fs] - _ -> prtBad "record expected, found" t - -typeType, typePType, typeStr, typeTok, typeStrs :: Term - -typeType = srt "Type" -typePType = srt "PType" -typeStr = srt "Str" -typeTok = srt "Tok" -typeStrs = srt "Strs" - -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 - -constPredefRes :: String -> Term -constPredefRes s = Q (IC "Predef") (zIdent s) - -constPredefAbs :: String -> Term -constPredefAbs s = Q (IC "Predef") (zIdent s) - -isPredefConstant :: Term -> Bool -isPredefConstant t = case t of - Q (IC "Predef") _ -> True - Q (IC "PredefAbs") _ -> True - _ -> False - -isPredefAbsType :: Ident -> Bool -isPredefAbsType c = elem c [zIdent "Int", zIdent "String"] - -mkSelects :: Term -> [Term] -> Term -mkSelects t tt = foldl S t tt - -mkTable :: [Term] -> Term -> Term -mkTable tt t = foldr Table t tt - -mkCTable :: [Ident] -> Term -> Term -mkCTable ids v = foldr ccase v ids where - ccase x t = T TRaw [(PV x,t)] - -mkDecl :: Term -> Decl -mkDecl typ = (wildIdent, typ) - -eqStrIdent :: Ident -> Ident -> Bool -eqStrIdent = (==) - -tupleLabel, linLabel :: Int -> Label -tupleLabel i = LIdent $ "p" ++ show i -linLabel i = LIdent $ "s" ++ show i - -theLinLabel :: Label -theLinLabel = LIdent "s" - -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] - -mkCases :: Ident -> Term -> Term -mkCases x t = T TRaw [(PV x, t)] - -mkWildCases :: Term -> Term -mkWildCases = mkCases wildIdent - -mkFunType :: [Type] -> Type -> Type -mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod - -plusRecType :: Type -> Type -> Err Type -plusRecType t1 t2 = case (unComputed t1, unComputed 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 prt ls) - _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt 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" +++ prt t1 +++ "and" +++ prt t2) - --- | default linearization type -defLinType :: Type -defLinType = RecType [(LIdent "s", typeStr)] - --- | refreshing variables -varX :: Int -> Ident -varX i = identV (i,"x") - --- | refreshing variables -mkFreshVar :: [Ident] -> Ident -mkFreshVar olds = varX (maxVarIndex olds + 1) - --- | trying to preserve a given symbol -mkFreshVarX :: [Ident] -> Ident -> Ident -mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x - -maxVarIndex :: [Ident] -> Int -maxVarIndex = maximum . ((-1):) . map varIndex - -mkFreshVars :: Int -> [Ident] -> [Ident] -mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]] - --- | quick hack for refining with var in editor -freshAsTerm :: String -> Term -freshAsTerm s = Vr (varX (readIntArg s)) - --- | create a terminal for concrete syntax -string2term :: String -> Term -string2term = K - -int2term :: Integer -> Term -int2term = EInt - -float2term :: Double -> Term -float2term = EFloat - --- | create a terminal from identifier -ident2terminal :: Ident -> Term -ident2terminal = K . prIdent - --- | create a constant -string2CnTrm :: String -> Term -string2CnTrm = Cn . zIdent - -symbolOfIdent :: Ident -> String -symbolOfIdent = prIdent - -symid :: Ident -> String -symid = symbolOfIdent - -vr :: Ident -> Term -cn :: Ident -> Term -srt :: String -> Term -meta :: MetaSymb -> Term -cnIC :: String -> Term - -vr = Vr -cn = Cn -srt = Sort -meta = Meta -cnIC = cn . IC - -justIdentOf :: Term -> Maybe Ident -justIdentOf (Vr x) = Just x -justIdentOf (Cn x) = Just x -justIdentOf _ = Nothing - -isMeta :: Term -> Bool -isMeta (Meta _) = True -isMeta _ = False - -mkMeta :: Int -> Term -mkMeta = Meta . MetaSymb - -nextMeta :: MetaSymb -> MetaSymb -nextMeta = int2meta . succ . metaSymbInt - -int2meta :: Int -> MetaSymb -int2meta = MetaSymb - -metaSymbInt :: MetaSymb -> Int -metaSymbInt (MetaSymb k) = k - -freshMeta :: [MetaSymb] -> MetaSymb -freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms], - notElem n (map metaSymbInt ms)]) - -mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm -mkFreshMetasInTrm metas = fst . rms minMeta where - rms meta trm = case trm of - Meta m -> (Meta (MetaSymb meta), meta + 1) - App f a -> let (f',msf) = rms meta f - (a',msa) = rms msf a - in (App f' a', msa) - Prod x a b -> - let (a',msa) = rms meta a - (b',msb) = rms msa b - in (Prod x a' b', msb) - Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb) - _ -> (trm,meta) - minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1) - --- | decides that a term has no metavariables -isCompleteTerm :: Term -> Bool -isCompleteTerm t = case t of - Meta _ -> False - Abs _ b -> isCompleteTerm b - App f a -> isCompleteTerm f && isCompleteTerm a - _ -> True - -linTypeStr :: Type -linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str} - -linAsStr :: String -> Term -linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s} - -linDefStr :: Term -linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s" - -term2patt :: Term -> Err Patt -term2patt trm = case termForm trm of - Ok ([], Vr x, []) -> return (PV x) - Ok ([], Val ty x, []) -> return (PVal ty x) - Ok ([], Con c, aa) -> do - aa' <- mapM term2patt aa - return (PC c aa') - Ok ([], QC p c, aa) -> do - aa' <- mapM term2patt aa - return (PP p c aa') - - Ok ([], Q p c, []) -> do - return (PM p c) - - 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 ([], Cn (IC "@"), [Vr a,b]) -> do - b' <- term2patt b - return (PAs a b') - Ok ([], Cn (IC "-"), [a]) -> do - a' <- term2patt a - return (PNeg a') - Ok ([], Cn (IC "*"), [a]) -> do - a' <- term2patt a - return (PRep a') - Ok ([], Cn (IC "?"), []) -> do - return PChar - Ok ([], Cn (IC "[]"),[K s]) -> do - return $ PChars s - Ok ([], Cn (IC "+"), [a,b]) -> do - a' <- term2patt a - b' <- term2patt b - return (PSeq a' b') - Ok ([], Cn (IC "|"), [a,b]) -> do - a' <- term2patt a - b' <- term2patt b - return (PAlt a' b') - - Ok ([], Cn c, []) -> do - return (PMacro c) - - _ -> prtBad "no pattern corresponds to term" trm - -patt2term :: Patt -> Term -patt2term pt = case pt of - PV x -> Vr x - PW -> Vr wildIdent --- not parsable, should not occur - PVal t i -> Val t i - PMacro c -> Cn c - PM p c -> Q p c - - 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 - PChar -> appc "?" [] --- an encoding - PChars s -> appc "[]" [K s] --- 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 - - -redirectTerm :: Ident -> Term -> Term -redirectTerm n t = case t of - QC _ f -> QC n f - Q _ f -> Q n f - _ -> composSafeOp (redirectTerm n) t - --- | to gather s-fields; assumes term in normal form, preserves label -allLinFields :: Term -> Err [[(Label,Term)]] -allLinFields trm = case unComputed trm of ----- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good - R rs -> return [[(l,t) | (l,(_,t)) <- rs, isLinLabel l]] ---- bad - FV ts -> do - lts <- mapM allLinFields ts - return $ concat lts - _ -> prtBad "fields can only be sought in a record not in" trm - --- | deprecated -isLinLabel :: Label -> Bool -isLinLabel l = case l of - LIdent ('s':cs) | all isDigit cs -> True - _ -> False - --- | to gather ultimate cases in a table; preserves pattern list -allCaseValues :: Term -> [([Patt],Term)] -allCaseValues trm = case unComputed trm of - T _ cs -> [(p:ps, t) | (p,t0) <- cs, (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 mark str parts of fields in a record f by a function f -markLinFields :: (Term -> Term) -> Term -> Term -markLinFields f t = case t of - R r -> R $ map mkField r - _ -> t - where - mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t) - mkTbl t = case t of - T i cs -> T i [(p, mkTbl v) | (p,v) <- cs] - _ -> f t - --- | to get a string from a term that represents a sequence of terminals -strsFromTerm :: Term -> Err [Str] -strsFromTerm t = case unComputed 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 - Strs ts -> mapM strsFromTerm ts >>= return . concat - Ready ss -> return [ss] - Alias _ _ d -> strsFromTerm d --- should not be needed... - _ -> prtBad "cannot get Str from term" t - --- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg -stringFromTerm :: Term -> String -stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm - - --- | 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 - 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') - - TSh i cc -> - do cc' <- mapPairListM (co . snd) cc - i' <- changeTableType co i - return (TSh i' cc') - - Eqs cc -> - do cc' <- mapPairListM (co . snd) cc - return (Eqs cc') - - V ty vs -> - do ty' <- co ty - vs' <- mapM co vs - return (V ty' vs') - - Val ty i -> - do ty' <- co ty - return (Val ty' i) - - 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') - Alias c ty d -> - do v <- co d - ty' <- co ty - return $ Alias c ty' v - 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 - Strs tt -> mapM co tt >>= return . Strs - - EPattType ty -> - do ty' <- co ty - return (EPattType ty') - - _ -> return trm -- covers K, Vr, Cn, Sort, EPatt - -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" - -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 - -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 - TSh _ 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 - Strs tt -> concatMap co tt - _ -> [] -- covers K, Vr, Cn, Sort, Ready - --- | to find the word items in a term -wordsInTerm :: Term -> [String] -wordsInTerm trm = filter (not . null) $ case trm of - K s -> [s] - S c _ -> wo c - Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa - Ready s -> allItems s - _ -> collectOp wo trm - where wo = wordsInTerm - -noExist :: Term -noExist = FV [] - -defaultLinType :: Type -defaultLinType = mkRecType linLabel [typeStr] - -metaTerms :: [Term] -metaTerms = map (Meta . MetaSymb) [0..] - --- | from GF1, 20\/9\/2003 -isInOneType :: Type -> Bool -isInOneType t = case t of - Prod _ a b -> a == b - _ -> False - diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs deleted file mode 100644 index b96d35b93..000000000 --- a/src/GF/Grammar/PatternMatch.hs +++ /dev/null @@ -1,155 +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.Grammar.PatternMatch (matchPattern, - testOvershadow, - findMatch - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Grammar.PrGrammar - -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 - t' <- termForm t - trym p t' - where - isInConstantFormt = True -- tested already - trym p t' = - case (p,t') of - (PVal _ i, (_,Val _ j,_)) - | i == j -> return [] - | otherwise -> Bad $ "no match of values" - (_,(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' - (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) - --- (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 - -isInConstantForm :: Term -> Bool -isInConstantForm trm = case trm of - Cn _ -> True - 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 - Alias _ _ t -> isInConstantForm t - 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 - _ -> [] - --- | to search matching parameter combinations in tables -isMatchingForms :: [Patt] -> [Term] -> Bool -isMatchingForms ps ts = all match (zip ps ts') where - match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds - match _ = True - ts' = map appForm ts - diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs deleted file mode 100644 index c3a21d1d6..000000000 --- a/src/GF/Grammar/PrGrammar.hs +++ /dev/null @@ -1,286 +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 --- --- printing and prettyprinting class --- --- 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.Grammar.PrGrammar (Print(..), - prtBad, - prGrammar, prModule, - prContext, prParam, - prQIdent, prQIdent_, - prRefinement, prTermOpt, - prt_Tree, prMarkedTree, prTree, - tree2string, prprTree, - prConstrs, prConstraints, - prMetaSubst, prEnv, prMSubst, - prExp, prPatt, prOperSignature, - lookupIdent, lookupIdentInfo - ) where - -import GF.Data.Operations -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 - -import GF.Infra.Option -import GF.Infra.Ident -import GF.Data.Str - -import GF.Infra.CompactPrint - -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. - --- | to show terms etc in error messages -prtBad :: Print a => String -> a -> Err b -prtBad s a = Bad (s +++ prt a) - -pprintTree :: P.Print a => a -> String -pprintTree = compactPrint . P.printTree - -prGrammar :: SourceGrammar -> String -prGrammar = pprintTree . trGrammar - -prModule :: (Ident, SourceModInfo) -> String -prModule = pprintTree . trModule - -instance Print Term where - prt = pprintTree . trt - prt_ = prExp - -instance Print Ident where - prt = pprintTree . tri - -instance Print Patt where - prt = pprintTree . trp - -instance Print Label where - prt = pprintTree . 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] - --- 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) - --- | 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 - -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 - --- | 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/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs deleted file mode 100644 index bc77c1837..000000000 --- a/src/GF/Grammar/Refresh.hs +++ /dev/null @@ -1,133 +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 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.Refresh (refreshTerm, refreshTermN, - refreshModule - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import Control.Monad - -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' <- refVar 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 (refVar 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) - --- for concrete and resource in grammar, before optimizing - -refreshGrammar :: SourceGrammar -> Err SourceGrammar -refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules - -refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) -refreshModule (k,ms) mi@(i,m) = case m of - ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do - (k',js') <- foldM refreshRes (k,[]) $ tree2list js - return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms) - _ -> return (k, mi:ms) - where - refreshRes (k,cs) ci@(c,info) = case info of - ResOper ptyp (Yes trm) -> do ---- refresh ptyp - (k',trm') <- refreshTermKN k trm - return $ (k', (c, ResOper ptyp (Yes trm')):cs) - ResOverload tyts -> do - (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (mapPairsM refresh tyts) (initIdStateN k) - return $ (k', (c, ResOverload tyts'):cs) - CncCat mt (Yes trm) pn -> do ---- refresh mt, pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncCat mt (Yes trm') pn):cs) - CncFun mt (Yes trm) pn -> do ---- refresh pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncFun mt (Yes trm') pn):cs) - _ -> return (k, ci:cs) - diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs deleted file mode 100644 index b440141d6..000000000 --- a/src/GF/Grammar/ReservedWords.hs +++ /dev/null @@ -1,44 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReservedWords --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:28 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- reserved words of GF. (c) Aarne Ranta 19\/3\/2002 under Gnu GPL. --- modified by Markus Forsberg 9\/4. --- modified by AR 12\/6\/2003 for GF2 and GFC ------------------------------------------------------------------------------ - -module GF.Grammar.ReservedWords (isResWord, isResWordGFC) where - -import Data.List - - -isResWord :: String -> Bool -isResWord s = isInTree s resWordTree - -resWordTree :: BTree -resWordTree = --- mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords --- nowadays obtained from LexGF.hs - B "let" (B "data" (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 "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N)))) - -isResWordGFC :: String -> Bool -isResWordGFC s = isInTree s $ - B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N))) - -data BTree = N | B String BTree BTree deriving (Show) - -isInTree :: String -> BTree -> Bool -isInTree x tree = case tree of - N -> False - B a left right - | x < a -> isInTree x left - | x > a -> isInTree x right - | x == a -> True - diff --git a/src/GF/Grammar/SGrammar.hs b/src/GF/Grammar/SGrammar.hs deleted file mode 100644 index e0c001b6b..000000000 --- a/src/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/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs deleted file mode 100644 index be52d1889..000000000 --- a/src/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/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs deleted file mode 100644 index 97b7ff243..000000000 --- a/src/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/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs deleted file mode 100644 index 588c1b306..000000000 --- a/src/GF/Grammar/Unify.hs +++ /dev/null @@ -1,96 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Unify --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:31 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (c) Petri Mäenpää & Aarne Ranta, 1998--2001 --- --- brute-force adaptation of the old-GF program AR 21\/12\/2001 --- --- the only use is in 'TypeCheck.splitConstraints' ------------------------------------------------------------------------------ - -module GF.Grammar.Unify (unifyVal) where - -import GF.Grammar.Abstract - -import GF.Data.Operations - -import Data.List (partition) - -unifyVal :: Constraints -> Err (Constraints,MetaSubst) -unifyVal cs0 = do - let (cs1,cs2) = partition notSolvable cs0 - let (us,vs) = unzip cs1 - us' <- mapM val2exp us - vs' <- mapM val2exp vs - let (ms,cs) = unifyAll (zip us' vs') [] - return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], - [(m, VClos [] t) | (m,t) <- ms]) - where - notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures - (VClos (_:_) _,_) -> True - (_,VClos (_:_) _) -> True - _ -> False - -type Unifier = [(MetaSymb, Trm)] -type Constrs = [(Trm, Trm)] - -unifyAll :: Constrs -> Unifier -> (Unifier,Constrs) -unifyAll [] g = (g, []) -unifyAll ((a@(s, t)) : l) g = - let (g1, c) = unifyAll l g - in case unify s t g1 of - Ok g2 -> (g2, c) - _ -> (g1, a : c) - -unify :: Trm -> Trm -> Unifier -> Err Unifier -unify e1 e2 g = - case (e1, e2) of - (Meta s, t) -> do - tg <- subst_all g t - let sg = maybe e1 id (lookup s g) - if (sg == Meta s) then extend g s tg else unify sg tg g - (t, Meta s) -> unify e2 e1 g - (Q _ a, Q _ b) | (a == b) -> return g ---- qualif? - (QC _ a, QC _ b) | (a == b) -> return g ---- - (Vr x, Vr y) | (x == y) -> return g - (Abs x b, Abs y c) -> do let c' = substTerm [x] [(y,Vr x)] c - unify b c' g - (App c a, App d b) -> case unify c d g of - Ok g1 -> unify a b g1 - _ -> prtBad "fail unify" e1 - _ -> prtBad "fail unify" e1 - -extend :: Unifier -> MetaSymb -> Trm -> Err Unifier -extend g s t | (t == Meta s) = return g - | occCheck s t = prtBad "occurs check" t - | True = return ((s, t) : g) - -subst_all :: Unifier -> Trm -> Err Trm -subst_all s u = - case (s,u) of - ([], t) -> return t - (a : l, t) -> do - t' <- (subst_all l t) --- successive substs - why ? - return $ substMetas [a] t' - -substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm -substMetas subst trm = case trm of - Meta x -> case lookup x subst of - Just t -> t - _ -> trm - _ -> composSafeOp (substMetas subst) trm - -occCheck :: MetaSymb -> Trm -> Bool -occCheck s u = case u of - Meta v -> s == v - App c a -> occCheck s c || occCheck s a - Abs x b -> occCheck s b - _ -> False - diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs deleted file mode 100644 index 6e029d98b..000000000 --- a/src/GF/Grammar/Values.hs +++ /dev/null @@ -1,109 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Values --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:32 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.Values (-- * values used in TC type checking - Exp, Val(..), Env, - -- * annotated tree used in editing - Tree, TrNode(..), Atom(..), Binds, Constraints, MetaSubst, - -- * for TC - valAbsInt, valAbsFloat, valAbsString, vType, - isPredefCat, - cType, cPredefAbs, cInt, cFloat, cString, - eType, tree2exp, loc2treeFocus - ) where - -import GF.Data.Operations -import GF.Data.Zipper - -import GF.Grammar.Grammar -import GF.Infra.Ident - --- values used in TC type checking - -type Exp = Term - -data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp - deriving (Eq,Show) - -type Env = [(Ident,Val)] - --- annotated tree used in editing - -type Tree = Tr TrNode - -newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool) - deriving (Eq,Show) - -data Atom = - AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Integer | AtF Double - deriving (Eq,Show) - -type Binds = [(Ident,Val)] -type Constraints = [(Val,Val)] -type MetaSubst = [(MetaSymb,Val)] - --- for TC - -valAbsInt :: Val -valAbsInt = VCn (cPredefAbs, cInt) - -valAbsFloat :: Val -valAbsFloat = VCn (cPredefAbs, cFloat) - -valAbsString :: Val -valAbsString = VCn (cPredefAbs, cString) - -vType :: Val -vType = VType - -cType :: Ident -cType = identC "Type" --- #0 - -cPredefAbs :: Ident -cPredefAbs = identC "PredefAbs" - -cInt :: Ident -cInt = identC "Int" - -cFloat :: Ident -cFloat = identC "Float" - -cString :: Ident -cString = identC "String" - -isPredefCat :: Ident -> Bool -isPredefCat c = elem c [cInt,cString,cFloat] - -eType :: Exp -eType = Sort "Type" - -tree2exp :: Tree -> Exp -tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where - at' = case at of - AtC (m,c) -> Q m c - AtV i -> Vr i - AtM m -> Meta m - AtL s -> K s - AtI s -> EInt s - AtF s -> EFloat s - bi' = map fst bi - ts' = map tree2exp ts - -loc2treeFocus :: Loc TrNode -> Tree -loc2treeFocus (Loc (Tr (a,ts),p)) = - loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) - where - (mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True), - \(N (a,b,c,d,_)) -> N(a,b,c,d,False)) - diff --git a/src/GF/IDE/IDECommands.hs b/src/GF/IDE/IDECommands.hs deleted file mode 100644 index 56d392a71..000000000 --- a/src/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/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs deleted file mode 100644 index 251ed2b8b..000000000 --- a/src/GF/Infra/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.Infra.CheckM (Check, - checkError, checkCond, checkWarn, checkUpdate, checkInContext, - checkUpdates, checkReset, checkResets, checkGetContext, - checkLookup, checkStart, checkErr, checkVal, checkIn, - prtFail - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.PrGrammar - --- | 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/GF/Infra/Comments.hs b/src/GF/Infra/Comments.hs deleted file mode 100644 index 0126db468..000000000 --- a/src/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/GF/Infra/CompactPrint.hs b/src/GF/Infra/CompactPrint.hs deleted file mode 100644 index 486c9e183..000000000 --- a/src/GF/Infra/CompactPrint.hs +++ /dev/null @@ -1,22 +0,0 @@ -module GF.Infra.CompactPrint where -import Data.Char - -compactPrint = compactPrintCustom keywordGF (const False) - -compactPrintGFCC = compactPrintCustom (const False) keywordGFCC - -compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words - -dps = dropWhile isSpace - -spaceIf pre post w = case w of - _ | pre w -> "\n" ++ w - _ | post w -> w ++ "\n" - c:_ | isAlpha c || isDigit c -> " " ++ w - '_':_ -> " " ++ w - _ -> w - -keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"] -keywordGFCC w = - last w == ';' || - elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"] diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs deleted file mode 100644 index 5ed860990..000000000 --- a/src/GF/Infra/Ident.hs +++ /dev/null @@ -1,155 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Ident --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 11:43:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.Ident (-- * Identifiers - Ident(..), prIdent, - identC, identV, identA, identAV, identW, - argIdent, strVar, wildIdent, isWildIdent, - newIdent, mkIdent, varIndex, - -- * refreshing identifiers - IdState, initIdStateN, initIdState, - lookVar, refVar, refVarPlus - ) where - -import GF.Data.Operations --- import Monad - - --- | the constructors labelled /INTERNAL/ are --- internal representation never returned by the parser -data Ident = - IC String -- ^ raw identifier after parsing, resolved in Rename - | IW -- ^ wildcard --- --- below this constructor: internal representation never returned by the parser - | IV (Int,String) -- ^ /INTERNAL/ variable - | IA (String,Int) -- ^ /INTERNAL/ argument of cat at position - | IAV (String,Int,Int) -- ^ /INTERNAL/ argument of cat with bindings at position --- - - deriving (Eq, Ord, Show, Read) - -prIdent :: Ident -> String -prIdent i = case i of - IC s -> s - IV (n,s) -> s ++ "_" ++ show n - IA (s,j) -> s ++ "_" ++ show j - IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j - IW -> "_" - -identC :: String -> Ident -identV :: (Int, String) -> Ident -identA :: (String, Int) -> Ident -identAV:: (String, Int, Int) -> Ident -identW :: Ident -(identC, identV, identA, identAV, identW) = - (IC, IV, IA, IAV, IW) - --- normal identifier --- ident s = IC s - --- | to mark argument variables -argIdent :: Int -> Ident -> Int -> Ident -argIdent 0 (IC c) i = identA (c,i) -argIdent b (IC c) i = identAV (c,b,i) - --- | used in lin defaults -strVar :: Ident -strVar = identA ("str",0) - --- | wild card -wildIdent :: Ident -wildIdent = identW - -isWildIdent :: Ident -> Bool -isWildIdent x = case x of - IW -> True - IC "_" -> True - _ -> False - -newIdent :: Ident -newIdent = identC "#h" - -mkIdent :: String -> Int -> Ident -mkIdent s i = identV (i,s) - -varIndex :: Ident -> Int -varIndex (IV (n,_)) = n -varIndex _ = -1 --- other than IV should not count - --- refreshing identifiers - -type IdState = ([(Ident,Ident)],Int) - -initIdStateN :: Int -> IdState -initIdStateN i = ([],i) - -initIdState :: IdState -initIdState = initIdStateN 0 - -lookVar :: Ident -> STM IdState Ident -lookVar a@(IA _) = return a -lookVar x = do - (sys,_) <- readSTM - stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) - return $ - lookup x sys >>= (\y -> return (y,s))) - -refVar :: Ident -> STM IdState Ident -----refVar IW = return IW --- no update of wildcard -refVar x = do - (_,m) <- readSTM - let x' = IV (m, prIdent x) - updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1)) - return x' - -refVarPlus :: Ident -> STM IdState Ident -----refVarPlus IW = refVar (identC "h") -refVarPlus x = refVar x - - -{- ------------------------------- --- to test - -refreshExp :: Exp -> Err Exp -refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState) - -refresh :: Exp -> STM State Exp -refresh e = case e of - Atom x -> lookVar x >>= return . Atom - App f a -> liftM2 App (refresh f) (refresh a) - Abs x b -> liftM2 Abs (refVar x) (refresh b) - Fun xs a b -> do - a' <- refresh a - xs' <- mapM refVar xs - b' <- refresh b - return $ Fun xs' a' b' - -data Exp = - Atom Ident - | App Exp Exp - | Abs Ident Exp - | Fun [Ident] Exp Exp - deriving Show - -exp1 = Abs (IC "y") (Atom (IC "y")) -exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))) -exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z")))) -exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z")))) -exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))) -exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y"))) -exp7 = Abs (IL "8") (Atom (IC "y")) - --} diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs deleted file mode 100644 index 4d50608c6..000000000 --- a/src/GF/Infra/Modules.hs +++ /dev/null @@ -1,416 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Modules --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/09 15:14:30 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Datastructures and functions for modules, common to GF and GFC. --- --- AR 29\/4\/2003 --- --- The same structure will be used in both source code and canonical. --- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order ------------------------------------------------------------------------------ - -module GF.Infra.Modules ( - MGrammar(..), ModInfo(..), Module(..), ModuleType(..), - MReuseType(..), MInclude (..), - extends, isInherited,inheritAll, - updateMGrammar, updateModule, replaceJudgements, addFlag, - addOpenQualif, flagsModule, allFlags, mapModules, - MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..), - oSimple, oQualif, - ModuleStatus(..), - openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar, - allExtends, allExtendSpecs, allExtendsPlus, allExtensions, - searchPathModule, addModule, - emptyMGrammar, emptyModInfo, emptyModule, - IdentM(..), - typeOfModule, abstractOfConcrete, abstractModOfConcrete, - lookupModule, lookupModuleType, lookupModMod, lookupInfo, - allModMod, isModAbs, isModRes, isModCnc, isModTrans, - sameMType, isCompilableModule, isCompleteModule, - allAbstracts, greatestAbstract, allResources, - greatestResource, allConcretes, allConcreteModules - ) where - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Operations - -import Data.List - - --- AR 29/4/2003 - --- The same structure will be used in both source code and canonical. --- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order - -data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]} - deriving Show - -data ModInfo i f a = - ModMainGrammar (MainGrammar i) - | ModMod (Module i f a) - | ModWith (Module i f a) (i,MInclude i) [OpenSpec i] - deriving Show - -data Module i f a = Module { - mtype :: ModuleType i , - mstatus :: ModuleStatus , - flags :: [f] , - extend :: [(i,MInclude i)], - opens :: [OpenSpec i] , - jments :: BinTree i a - } ---- deriving Show -instance Show (Module i f a) where - show _ = "cannot show Module with FiniteMap" - --- | encoding the type of the module -data ModuleType i = - MTAbstract - | MTTransfer (OpenSpec i) (OpenSpec i) - | MTResource - | MTConcrete i - -- ^ up to this, also used in GFC. Below, source only. - | MTInterface - | MTInstance i - | MTReuse (MReuseType i) - | MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive - deriving (Eq,Show) - -data MReuseType i = MRInterface i | MRInstance i i | MRResource i - deriving (Show,Eq) - -data MInclude i = MIAll | MIOnly [i] | MIExcept [i] - deriving (Show,Eq) - -extends :: Module i f a -> [i] -extends = map fst . extend - -isInherited :: Eq i => MInclude i -> i -> Bool -isInherited c i = case c of - MIAll -> True - MIOnly is -> elem i is - MIExcept is -> notElem i is - -inheritAll :: i -> (i,MInclude i) -inheritAll i = (i,MIAll) - --- destructive update - --- | dep order preserved since old cannot depend on new -updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a -updateMGrammar old new = MGrammar $ - [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns - where - os = modules old - ns = modules new - -updateModule :: Ord i => Module i f t -> i -> t -> Module i f t -updateModule (Module mt ms fs me ops js) i t = - Module mt ms fs me ops (updateTree (i,t) js) - -replaceJudgements :: Module i f t -> BinTree i t -> Module i f t -replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js - -addOpenQualif :: i -> i -> Module i f t -> Module i f t -addOpenQualif i j (Module mt ms fs me ops js) = - Module mt ms fs me (oQualif i j : ops) js - -addFlag :: f -> Module i f t -> Module i f t -addFlag f mo = mo {flags = f : flags mo} - -flagsModule :: (i,ModInfo i f a) -> [f] -flagsModule (_,mi) = case mi of - ModMod m -> flags m - _ -> [] - -allFlags :: MGrammar i f a -> [f] -allFlags gr = concat $ map flags $ [m | (_, ModMod m) <- modules gr] - -mapModules :: (Module i f a -> Module i f a) - -> MGrammar i f a -> MGrammar i f a -mapModules f = MGrammar . map (onSnd mapModules') . modules - where mapModules' (ModMod m) = ModMod (f m) - mapModules' m = m - -data MainGrammar i = MainGrammar { - mainAbstract :: i , - mainConcretes :: [MainConcreteSpec i] - } - deriving Show - -data MainConcreteSpec i = MainConcreteSpec { - concretePrintname :: i , - concreteName :: i , - transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer - transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer - } - deriving Show - -data OpenSpec i = - OSimple OpenQualif i - | OQualif OpenQualif i i - deriving (Eq,Show) - -data OpenQualif = - OQNormal - | OQInterface - | OQIncomplete - deriving (Eq,Show) - -oSimple :: i -> OpenSpec i -oSimple = OSimple OQNormal - -oQualif :: i -> i -> OpenSpec i -oQualif = OQualif OQNormal - -data ModuleStatus = - MSComplete - | MSIncomplete - deriving (Eq,Show) - -openedModule :: OpenSpec i -> i -openedModule o = case o of - OSimple _ m -> m - OQualif _ _ m -> m - -allOpens :: Module i f a -> [OpenSpec i] -allOpens m = case mtype m of - MTTransfer a b -> a : b : opens m - _ -> opens m - --- | initial dependency list -depPathModule :: Ord i => Module i f a -> [OpenSpec i] -depPathModule m = fors m ++ exts m ++ opens m where - fors m = case mtype m of - MTTransfer i j -> [i,j] - MTConcrete i -> [oSimple i] - MTInstance i -> [oSimple i] - _ -> [] - exts m = map oSimple $ extends m - --- | all dependencies -allDepsModule :: Ord i => MGrammar i f a -> Module i f a -> [OpenSpec i] -allDepsModule gr m = iterFix add os0 where - os0 = depPathModule m - add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods], - m <- depPathModule n] - mods = modules gr - --- | select just those modules that a given one depends on, including itself -partOfGrammar :: Ord i => MGrammar i f a -> (i,ModInfo i f a) -> MGrammar i f a -partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] - where - mods = modules gr - modsFor = case m of - ModMod n -> (i:) $ map openedModule $ allDepsModule gr n - ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ---- - _ -> [i] - --- | all modules that a module extends, directly or indirectly, without restricts -allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i] -allExtends gr i = case lookupModule gr i of - Ok (ModMod m) -> case extends m of - [] -> [i] - is -> i : concatMap (allExtends gr) is - _ -> [] - --- | all modules that a module extends, directly or indirectly, with restricts -allExtendSpecs :: (Show i,Ord i) => MGrammar i f a -> i -> [(i,MInclude i)] -allExtendSpecs gr i = case lookupModule gr i of - Ok (ModMod m) -> case extend m of - [] -> [(i,MIAll)] - is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is - _ -> [] - --- | this plus that an instance extends its interface -allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i] -allExtendsPlus gr i = case lookupModule gr i of - Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m) - _ -> [] - where - exts m = extends m ++ [j | MTInstance j <- [mtype m]] - --- | conversely: all modules that extend a given module, incl. instances of interface -allExtensions :: (Show i,Ord i) => MGrammar i f a -> i -> [i] -allExtensions gr i = case lookupModule gr i of - Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es - _ -> [] - where - exts i = [j | (j,m) <- mods, elem i (extends m) - || elem (MTInstance i) [mtype m]] - mods = [(j,m) | (j,ModMod m) <- modules gr] - --- | initial search path: the nonqualified dependencies -searchPathModule :: Ord i => Module i f a -> [i] -searchPathModule m = [i | OSimple _ i <- depPathModule m] - --- | a new module can safely be added to the end, since nothing old can depend on it -addModule :: Ord i => - MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a -addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) - -emptyMGrammar :: MGrammar i f a -emptyMGrammar = MGrammar [] - -emptyModInfo :: ModInfo i f a -emptyModInfo = ModMod emptyModule - -emptyModule :: Module i f a -emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree - --- | we store the module type with the identifier -data IdentM i = IdentM { - identM :: i , - typeM :: ModuleType i - } - deriving (Eq,Show) - -typeOfModule :: ModInfo i f a -> ModuleType i -typeOfModule mi = case mi of - ModMod m -> mtype m - -abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i -abstractOfConcrete gr c = do - m <- lookupModule gr c - case m of - ModMod n -> case mtype n of - MTConcrete a -> return a - _ -> Bad $ "expected concrete" +++ show c - _ -> Bad $ "expected concrete" +++ show c - -abstractModOfConcrete :: (Show i, Eq i) => - MGrammar i f a -> i -> Err (Module i f a) -abstractModOfConcrete gr c = do - a <- abstractOfConcrete gr c - m <- lookupModule gr a - case m of - ModMod n -> return n - _ -> Bad $ "expected abstract" +++ show c - - --- the canonical file name - ---- canonFileName s = prt s ++ ".gfc" - -lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a) -lookupModule gr m = case lookup m (modules gr) of - Just i -> return i - _ -> Bad $ "unknown module" +++ show m - +++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug - -lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i) -lookupModuleType gr m = do - mi <- lookupModule gr m - return $ typeOfModule mi - -lookupModMod :: (Show i,Eq i) => MGrammar i f a -> i -> Err (Module i f a) -lookupModMod gr i = do - mo <- lookupModule gr i - case mo of - ModMod m -> return m - _ -> Bad $ "expected proper module, not" +++ show i - -lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a -lookupInfo mo i = lookupTree show i (jments mo) - -allModMod :: (Show i,Eq i) => MGrammar i f a -> [(i,Module i f a)] -allModMod gr = [(i,m) | (i, ModMod m) <- modules gr] - -isModAbs :: Module i f a -> Bool -isModAbs m = case mtype m of - MTAbstract -> True ----- MTUnion t -> isModAbs t - _ -> False - -isModRes :: Module i f a -> Bool -isModRes m = case mtype m of - MTResource -> True - MTReuse _ -> True ----- MTUnion t -> isModRes t --- maybe not needed, since eliminated early - MTInterface -> True --- - MTInstance _ -> True - _ -> False - -isModCnc :: Module i f a -> Bool -isModCnc m = case mtype m of - MTConcrete _ -> True ----- MTUnion t -> isModCnc t - _ -> False - -isModTrans :: Module i f a -> Bool -isModTrans m = case mtype m of - MTTransfer _ _ -> True ----- MTUnion t -> isModTrans t - _ -> False - -sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool -sameMType m n = case (n,m) of - (MTConcrete _, MTConcrete _) -> True - - (MTInstance _, MTInstance _) -> True - (MTInstance _, MTResource) -> True - (MTInstance _, MTConcrete _) -> True - - (MTInterface, MTInstance _) -> True - (MTInterface, MTResource) -> True -- for reuse - (MTInterface, MTAbstract) -> True -- for reuse - - (MTResource, MTInstance _) -> True - (MTResource, MTConcrete _) -> True -- for reuse - - _ -> m == n - --- | don't generate code for interfaces and for incomplete modules -isCompilableModule :: ModInfo i f a -> Bool -isCompilableModule m = case m of - ModMod m -> case mtype m of - MTInterface -> False - _ -> mstatus m == MSComplete - _ -> False --- - --- | interface and "incomplete M" are not complete -isCompleteModule :: (Eq i) => Module i f a -> Bool -isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface - - --- | all abstract modules sorted from least to most dependent -allAbstracts :: Eq i => MGrammar i f a -> [i] -allAbstracts gr = topoSort - [(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract] - --- | the last abstract in dependency order (head of list) -greatestAbstract :: Eq i => MGrammar i f a -> Maybe i -greatestAbstract gr = case allAbstracts gr of - [] -> Nothing - as -> return $ last as - --- | all resource modules -allResources :: MGrammar i f a -> [i] -allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m] - --- | the greatest resource in dependency order -greatestResource :: MGrammar i f a -> Maybe i -greatestResource gr = case allResources gr of - [] -> Nothing - a -> return $ head a - --- | all concretes for a given abstract -allConcretes :: Eq i => MGrammar i f a -> i -> [i] -allConcretes gr a = - [i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m] - --- | all concrete modules for any abstract -allConcreteModules :: Eq i => MGrammar i f a -> [i] -allConcreteModules gr = - [i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs deleted file mode 100644 index a44cd9db8..000000000 --- a/src/GF/Infra/Option.hs +++ /dev/null @@ -1,375 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Option --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/14 16:03:41 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.34 $ --- --- Options and flags used in GF shell commands and files. --- --- The types 'Option' and 'Options' should be kept abstract, but: --- --- - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource" --- --- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands" ------------------------------------------------------------------------------ - -module GF.Infra.Option where - -import Data.List (partition) -import Data.Char (isDigit) - --- * all kinds of options, to be kept abstract - -newtype Option = Opt (String,[String]) deriving (Eq,Show,Read) -newtype Options = Opts [Option] deriving (Eq,Show,Read) - -noOptions :: Options -noOptions = Opts [] - --- | simple option -o -iOpt :: String -> Option -iOpt o = Opt (o,[]) - --- | option with argument -o=a -aOpt :: String -> String -> Option -aOpt o a = Opt (o,[a]) - -iOpts :: [Option] -> Options -iOpts = Opts - --- | value of option argument -oArg :: String -> String -oArg s = s - -oElem :: Option -> Options -> Bool -oElem o (Opts os) = elem o os - -eqOpt :: String -> Option -> Bool -eqOpt s (Opt (o, [])) = s == o -eqOpt s _ = False - -type OptFun = String -> Option -type OptFunId = String - -getOptVal :: Options -> OptFun -> Maybe String -getOptVal (Opts os) fopt = - case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of - a:_ -> Just a - _ -> Nothing - -isSetFlag :: Options -> OptFun -> Bool -isSetFlag (Opts os) fopt = - case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of - a:_ -> True - _ -> False - -getOptInt :: Options -> OptFun -> Maybe Int -getOptInt opts f = do - s <- getOptVal opts f - if (not (null s) && all isDigit s) then return (read s) else Nothing - -optIntOrAll :: Options -> OptFun -> [a] -> [a] -optIntOrAll opts f = case getOptInt opts f of - Just i -> take i - _ -> id - -optIntOrN :: Options -> OptFun -> Int -> Int -optIntOrN opts f n = case getOptInt opts f of - Just i -> i - _ -> n - -optIntOrOne :: Options -> OptFun -> Int -optIntOrOne opts f = optIntOrN opts f 1 - -changeOptVal :: Options -> OptFun -> String -> Options -changeOptVal os f x = - addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f - -addOption :: Option -> Options -> Options -addOption o (Opts os) = iOpts (o:os) - -addOptions :: Options -> Options -> Options -addOptions (Opts os) os0 = foldr addOption os0 os - -concatOptions :: [Options] -> Options -concatOptions = foldr addOptions noOptions - -removeOption :: Option -> Options -> Options -removeOption o (Opts os) = iOpts (filter (/=o) os) - -removeOptions :: Options -> Options -> Options -removeOptions (Opts os) os0 = foldr removeOption os0 os - -options :: [Option] -> Options -options = foldr addOption noOptions - -unionOptions :: Options -> Options -> Options -unionOptions (Opts os) (Opts os') = Opts (os ++ os') - --- * parsing options, with prefix pre (e.g. \"-\") - -getOptions :: String -> [String] -> (Options, [String]) -getOptions pre inp = let - (os,rest) = span (isOption pre) inp -- options before args - in - (Opts (map (pOption pre) os), rest) - -pOption :: String -> String -> Option -pOption pre s = case span (/= '=') (drop (length pre) s) of - (f,_:a) -> aOpt f a - (o,[]) -> iOpt o - -isOption :: String -> String -> Bool -isOption pre = (==pre) . take (length pre) - --- * printing options, without prefix - -prOpt :: Option -> String -prOpt (Opt (s,[])) = s -prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs - -prOpts :: Options -> String -prOpts (Opts os) = unwords $ map prOpt os - --- * a suggestion for option names - --- ** parsing - -strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option --- | parse as term instead of string -dontParse :: Option - -strictParse = iOpt "strict" -forgiveParse = iOpt "n" -ignoreParse = iOpt "ign" -literalParse = iOpt "lit" -rawParse = iOpt "raw" -firstParse = iOpt "1" -dontParse = iOpt "read" - -newParser, newerParser, newCParser, newMParser :: Option -newParser = iOpt "new" -newerParser = iOpt "newer" -newCParser = iOpt "cfg" -newMParser = iOpt "mcfg" -newFParser = iOpt "fcfg" - -{- -useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option - -useParserMCFG = iOpt "mcfg" -useParserMCFGviaCFG = iOpt "mcfg-via-cfg" -useParserCFG = iOpt "cfg" -useParserCF = iOpt "cf" --} - --- ** grammar formats - -showAbstr, showXML, showOld, showLatex, showFullForm, - showEBNF, showCF, showWords, showOpts, - isCompiled, isHaskell, noCompOpers, retainOpers, - noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option -defaultGrOpts :: [Option] - -showAbstr = iOpt "abs" -showXML = iOpt "xml" -showOld = iOpt "old" -showLatex = iOpt "latex" -showFullForm = iOpt "fullform" -showEBNF = iOpt "ebnf" -showCF = iOpt "cf" -showWords = iOpt "ws" -showOpts = iOpt "opts" --- showOptim = iOpt "opt" -isCompiled = iOpt "gfc" -isHaskell = iOpt "gfhs" -noCompOpers = iOpt "nocomp" -retainOpers = iOpt "retain" -defaultGrOpts = [] -noCF = iOpt "nocf" -checkCirc = iOpt "nocirc" -noCheckCirc = iOpt "nocheckcirc" -lexerByNeed = iOpt "cflexer" -useUTF8id = iOpt "utf8id" -elimSubs = iOpt "subs" - --- ** linearization - -allLin, firstLin, distinctLin, dontLin, - showRecord, showStruct, xmlLin, latexLin, - tableLin, useUTF8, showLang, withMetas :: Option -defaultLinOpts :: [Option] - -allLin = iOpt "all" -firstLin = iOpt "one" -distinctLin = iOpt "nub" -dontLin = iOpt "show" -showRecord = iOpt "record" -showStruct = iOpt "structured" -xmlLin = showXML -latexLin = showLatex -tableLin = iOpt "table" -defaultLinOpts = [firstLin] -useUTF8 = iOpt "utf8" -showLang = iOpt "lang" -showDefs = iOpt "defs" -withMetas = iOpt "metas" - --- ** other - -beVerbose, showInfo, beSilent, emitCode, getHelp, - doMake, doBatch, notEmitCode, makeMulti, beShort, - wholeGrammar, makeFudget, byLines, byWords, analMorpho, - doTrace, noCPU, doCompute, optimizeCanon, optimizeValues, - stripQualif, nostripQualif, showAll, fromSource :: Option - -beVerbose = iOpt "v" -invertGrep = iOpt "v" --- same letter in unix -showInfo = iOpt "i" -beSilent = iOpt "s" -emitCode = iOpt "o" -getHelp = iOpt "help" -doMake = iOpt "make" -doBatch = iOpt "batch" -notEmitCode = iOpt "noemit" -makeMulti = iOpt "multi" -beShort = iOpt "short" -wholeGrammar = iOpt "w" -makeFudget = iOpt "f" -byLines = iOpt "lines" -byWords = iOpt "words" -analMorpho = iOpt "morpho" -doTrace = iOpt "tr" -noCPU = iOpt "nocpu" -doCompute = iOpt "c" -optimizeCanon = iOpt "opt" -optimizeValues = iOpt "val" -stripQualif = iOpt "strip" -nostripQualif = iOpt "nostrip" -showAll = iOpt "all" -showFields = iOpt "fields" -showMulti = iOpt "multi" -fromSource = iOpt "src" -makeConcrete = iOpt "examples" -fromExamples = iOpt "ex" -openEditor = iOpt "edit" -getTrees = iOpt "trees" - --- ** mainly for stand-alone - -useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option - -useUnicode = iOpt "unicode" -optCompute = iOpt "compute" -optCheck = iOpt "typecheck" -optParaphrase = iOpt "paraphrase" -forJava = iOpt "java" - --- ** for edit session - -allLangs, absView :: Option - -allLangs = iOpt "All" -absView = iOpt "Abs" - --- ** options that take arguments - -useTokenizer, useUntokenizer, useParser, withFun, - useLanguage, useResource, speechLanguage, useFont, - grammarFormat, grammarPrinter, filterString, termCommand, - transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay, - noDepTypes, extractGr, pathList, uniCoding :: String -> Option --- | used on command line -firstCat :: String -> Option --- | used in grammar, to avoid clash w res word -gStartCat :: String -> Option - -useTokenizer = aOpt "lexer" -useUntokenizer = aOpt "unlexer" -useParser = aOpt "parser" --- useStrategy = aOpt "strategy" -- parsing strategy -withFun = aOpt "fun" -firstCat = aOpt "cat" -gStartCat = aOpt "startcat" -useLanguage = aOpt "lang" -useResource = aOpt "res" -speechLanguage = aOpt "language" -useFont = aOpt "font" -grammarFormat = aOpt "format" -grammarPrinter = aOpt "printer" -filterString = aOpt "filter" -termCommand = aOpt "transform" -transferFun = aOpt "transfer" -forForms = aOpt "forms" -menuDisplay = aOpt "menu" -sizeDisplay = aOpt "size" -typeDisplay = aOpt "types" -noDepTypes = aOpt "nodeptypes" -extractGr = aOpt "extract" -pathList = aOpt "path" -uniCoding = aOpt "coding" -probFile = aOpt "probs" -noparseFile = aOpt "noparse" -usePreprocessor = aOpt "preproc" - --- peb 16/3-05: -gfcConversion :: String -> Option -gfcConversion = aOpt "conversion" - -useName, useAbsName, useCncName, useResName, - useFile, useOptimizer :: String -> Option - -useName = aOpt "name" -useAbsName = aOpt "abs" -useCncName = aOpt "cnc" -useResName = aOpt "res" -useFile = aOpt "file" -useOptimizer = aOpt "optimize" - -markLin :: String -> Option -markOptXML, markOptJava, markOptStruct, markOptFocus :: String - -markLin = aOpt "mark" -markOptXML = oArg "xml" -markOptJava = oArg "java" -markOptStruct = oArg "struct" -markOptFocus = oArg "focus" - - --- ** refinement order - -nextRefine :: String -> Option -firstRefine, lastRefine :: String - -nextRefine = aOpt "nextrefine" -firstRefine = oArg "first" -lastRefine = oArg "last" - --- ** Boolean flags - -flagYes, flagNo :: String - -flagYes = oArg "yes" -flagNo = oArg "no" - --- ** integer flags - -flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option - -flagDepth = aOpt "depth" -flagAlts = aOpt "alts" -flagLength = aOpt "length" -flagNumber = aOpt "number" -flagRawtrees = aOpt "rawtrees" - -caseYesNo :: Options -> OptFun -> Maybe Bool -caseYesNo opts f = do - v <- getOptVal opts f - if v == flagYes then return True - else if v == flagNo then return False - else Nothing diff --git a/src/GF/Infra/Print.hs b/src/GF/Infra/Print.hs deleted file mode 100644 index 17f2c2188..000000000 --- a/src/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/GF/Infra/PrintClass.hs b/src/GF/Infra/PrintClass.hs deleted file mode 100644 index 5e94984a6..000000000 --- a/src/GF/Infra/PrintClass.hs +++ /dev/null @@ -1,51 +0,0 @@ -module GF.Infra.PrintClass where - -import Data.List (intersperse) - -class Print a where - prt :: a -> String - prtList :: [a] -> String - prtList as = "[" ++ prtSep "," as ++ "]" - -prtSep :: Print a => String -> [a] -> String -prtSep sep = concat . intersperse sep . map prt - -prtBefore :: Print a => String -> [a] -> String -prtBefore before = prtBeforeAfter before "" - -prtAfter :: Print a => String -> [a] -> String -prtAfter after = prtBeforeAfter "" after - -prtBeforeAfter :: Print a => String -> String -> [a] -> String -prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ] - -prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String -prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ] -prIO :: Print a => a -> IO () -prIO = putStr . prt - -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" diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs deleted file mode 100644 index ce33ec23f..000000000 --- a/src/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/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs deleted file mode 100644 index 4125a0417..000000000 --- a/src/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/GF/JavaScript/AbsJS.hs b/src/GF/JavaScript/AbsJS.hs deleted file mode 100644 index 2632ade48..000000000 --- a/src/GF/JavaScript/AbsJS.hs +++ /dev/null @@ -1,60 +0,0 @@ -module GF.JavaScript.AbsJS where - --- Haskell module generated by the BNF converter - -newtype Ident = Ident String deriving (Eq,Ord,Show) -data Program = - Program [Element] - deriving (Eq,Ord,Show) - -data Element = - FunDef Ident [Ident] [Stmt] - | ElStmt Stmt - deriving (Eq,Ord,Show) - -data Stmt = - SCompound [Stmt] - | SReturnVoid - | SReturn Expr - | SDeclOrExpr DeclOrExpr - deriving (Eq,Ord,Show) - -data DeclOrExpr = - Decl [DeclVar] - | DExpr Expr - deriving (Eq,Ord,Show) - -data DeclVar = - DVar Ident - | DInit Ident Expr - deriving (Eq,Ord,Show) - -data Expr = - EAssign Expr Expr - | ENew Ident [Expr] - | EMember Expr Ident - | EIndex Expr Expr - | ECall Expr [Expr] - | EVar Ident - | EInt Int - | EDbl Double - | EStr String - | ETrue - | EFalse - | ENull - | EThis - | EFun [Ident] [Stmt] - | EArray [Expr] - | EObj [Property] - | ESeq [Expr] - deriving (Eq,Ord,Show) - -data Property = - Prop PropertyName Expr - deriving (Eq,Ord,Show) - -data PropertyName = - IdentPropName Ident - | StringPropName String - deriving (Eq,Ord,Show) - diff --git a/src/GF/JavaScript/JS.cf b/src/GF/JavaScript/JS.cf deleted file mode 100644 index fe31a2074..000000000 --- a/src/GF/JavaScript/JS.cf +++ /dev/null @@ -1,55 +0,0 @@ -entrypoints Program; - -Program. Program ::= [Element]; - -FunDef. Element ::= "function" Ident "(" [Ident] ")" "{" [Stmt] "}" ; -ElStmt. Element ::= Stmt; -separator Element "" ; - -separator Ident "," ; - -SCompound. Stmt ::= "{" [Stmt] "}" ; -SReturnVoid. Stmt ::= "return" ";" ; -SReturn. Stmt ::= "return" Expr ";" ; -SDeclOrExpr. Stmt ::= DeclOrExpr ";" ; -separator Stmt "" ; - -Decl. DeclOrExpr ::= "var" [DeclVar]; -DExpr. DeclOrExpr ::= Expr1 ; - -DVar. DeclVar ::= Ident ; -DInit. DeclVar ::= Ident "=" Expr ; -separator DeclVar "," ; - -EAssign. Expr13 ::= Expr14 "=" Expr13 ; - -ENew. Expr14 ::= "new" Ident "(" [Expr] ")" ; - -EMember. Expr15 ::= Expr15 "." Ident ; -EIndex. Expr15 ::= Expr15 "[" Expr "]" ; -ECall. Expr15 ::= Expr15 "(" [Expr] ")" ; - -EVar. Expr16 ::= Ident ; -EInt. Expr16 ::= Integer ; -EDbl. Expr16 ::= Double ; -EStr. Expr16 ::= String ; -ETrue. Expr16 ::= "true" ; -EFalse. Expr16 ::= "false" ; -ENull. Expr16 ::= "null" ; -EThis. Expr16 ::= "this" ; -EFun. Expr16 ::= "function" "(" [Ident] ")" "{" [Stmt] "}" ; -EArray. Expr16 ::= "[" [Expr] "]" ; -EObj. Expr16 ::= "{" [Property] "}" ; - -eseq1. Expr16 ::= "(" Expr "," [Expr] ")"; -internal ESeq. Expr16 ::= "(" [Expr] ")" ; -define eseq1 x xs = ESeq (x:xs); - -separator Expr "," ; -coercions Expr 16 ; - -Prop. Property ::= PropertyName ":" Expr ; -separator Property "," ; - -IdentPropName. PropertyName ::= Ident ; -StringPropName. PropertyName ::= String ; diff --git a/src/GF/JavaScript/LexJS.hs b/src/GF/JavaScript/LexJS.hs deleted file mode 100644 index 242831195..000000000 --- a/src/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/GF/JavaScript/LexJS.x b/src/GF/JavaScript/LexJS.x deleted file mode 100644 index 10ba66d69..000000000 --- a/src/GF/JavaScript/LexJS.x +++ /dev/null @@ -1,132 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.JavaScript.LexJS where - - -} - - -$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 = -- symbols and non-identifier-like reserved words - \( | \) | \{ | \} | \, | \; | \= | \. | \[ | \] | \: - -:- - -$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)) } -$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) } - -{ - -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 -} diff --git a/src/GF/JavaScript/Makefile b/src/GF/JavaScript/Makefile deleted file mode 100644 index 10f867b06..000000000 --- a/src/GF/JavaScript/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -all: - happy -gca ParJS.y - alex -g LexJS.x - -bnfc: - (cd ../.. && bnfc -p GF.JavaScript GF/JavaScript/JS.cf) - -rm -f *.bak - -clean: - -rm -f *.log *.aux *.hi *.o *.dvi - -rm -f DocJS.ps -distclean: clean - -rm -f DocJS.* LexJS.* ParJS.* LayoutJS.* SkelJS.* PrintJS.* TestJS.* AbsJS.* TestJS ErrM.* SharedString.* JS.dtd XMLJS.* Makefile* - diff --git a/src/GF/JavaScript/ParJS.hs b/src/GF/JavaScript/ParJS.hs deleted file mode 100644 index f57c44a22..000000000 --- a/src/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/GF/JavaScript/ParJS.y b/src/GF/JavaScript/ParJS.y deleted file mode 100644 index bf0614757..000000000 --- a/src/GF/JavaScript/ParJS.y +++ /dev/null @@ -1,225 +0,0 @@ --- This Happy file was machine-generated by the BNF converter -{ -{-# 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 -} - -%name pProgram Program - --- 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 ":") } - 'false' { PT _ (TS "false") } - 'function' { PT _ (TS "function") } - 'new' { PT _ (TS "new") } - 'null' { PT _ (TS "null") } - 'return' { PT _ (TS "return") } - 'this' { PT _ (TS "this") } - 'true' { PT _ (TS "true") } - 'var' { PT _ (TS "var") } - -L_ident { PT _ (TV $$) } -L_integ { PT _ (TI $$) } -L_doubl { PT _ (TD $$) } -L_quoted { PT _ (TL $$) } -L_err { _ } - - -%% - -Ident :: { Ident } : L_ident { Ident $1 } -Integer :: { Integer } : L_integ { (read $1) :: Integer } -Double :: { Double } : L_doubl { (read $1) :: Double } -String :: { String } : L_quoted { $1 } - -Program :: { Program } -Program : ListElement { Program (reverse $1) } - - -Element :: { Element } -Element : 'function' Ident '(' ListIdent ')' '{' ListStmt '}' { FunDef $2 $4 (reverse $7) } - | Stmt { ElStmt $1 } - - -ListElement :: { [Element] } -ListElement : {- empty -} { [] } - | ListElement Element { flip (:) $1 $2 } - - -ListIdent :: { [Ident] } -ListIdent : {- empty -} { [] } - | Ident { (:[]) $1 } - | Ident ',' ListIdent { (:) $1 $3 } - - -Stmt :: { Stmt } -Stmt : '{' ListStmt '}' { SCompound (reverse $2) } - | 'return' ';' { SReturnVoid } - | 'return' Expr ';' { SReturn $2 } - | DeclOrExpr ';' { SDeclOrExpr $1 } - - -ListStmt :: { [Stmt] } -ListStmt : {- empty -} { [] } - | ListStmt Stmt { flip (:) $1 $2 } - - -DeclOrExpr :: { DeclOrExpr } -DeclOrExpr : 'var' ListDeclVar { Decl $2 } - | Expr1 { DExpr $1 } - - -DeclVar :: { DeclVar } -DeclVar : Ident { DVar $1 } - | Ident '=' Expr { DInit $1 $3 } - - -ListDeclVar :: { [DeclVar] } -ListDeclVar : {- empty -} { [] } - | DeclVar { (:[]) $1 } - | DeclVar ',' ListDeclVar { (:) $1 $3 } - - -Expr13 :: { Expr } -Expr13 : Expr14 '=' Expr13 { EAssign $1 $3 } - | Expr14 { $1 } - - -Expr14 :: { Expr } -Expr14 : 'new' Ident '(' ListExpr ')' { ENew $2 $4 } - | Expr15 { $1 } - - -Expr15 :: { Expr } -Expr15 : Expr15 '.' Ident { EMember $1 $3 } - | Expr15 '[' Expr ']' { EIndex $1 $3 } - | Expr15 '(' ListExpr ')' { ECall $1 $3 } - | Expr16 { $1 } - - -Expr16 :: { Expr } -Expr16 : Ident { EVar $1 } - | Integer { EInt $1 } - | Double { EDbl $1 } - | String { EStr $1 } - | 'true' { ETrue } - | 'false' { EFalse } - | 'null' { ENull } - | 'this' { EThis } - | 'function' '(' ListIdent ')' '{' ListStmt '}' { EFun $3 (reverse $6) } - | '[' ListExpr ']' { EArray $2 } - | '{' ListProperty '}' { EObj $2 } - | '(' Expr ',' ListExpr ')' { eseq1_ $2 $4 } - | '(' Expr ')' { $2 } - - -ListExpr :: { [Expr] } -ListExpr : {- empty -} { [] } - | Expr { (:[]) $1 } - | Expr ',' ListExpr { (:) $1 $3 } - - -Expr :: { Expr } -Expr : Expr1 { $1 } - - -Expr1 :: { Expr } -Expr1 : Expr2 { $1 } - - -Expr2 :: { Expr } -Expr2 : Expr3 { $1 } - - -Expr3 :: { Expr } -Expr3 : Expr4 { $1 } - - -Expr4 :: { Expr } -Expr4 : Expr5 { $1 } - - -Expr5 :: { Expr } -Expr5 : Expr6 { $1 } - - -Expr6 :: { Expr } -Expr6 : Expr7 { $1 } - - -Expr7 :: { Expr } -Expr7 : Expr8 { $1 } - - -Expr8 :: { Expr } -Expr8 : Expr9 { $1 } - - -Expr9 :: { Expr } -Expr9 : Expr10 { $1 } - - -Expr10 :: { Expr } -Expr10 : Expr11 { $1 } - - -Expr11 :: { Expr } -Expr11 : Expr12 { $1 } - - -Expr12 :: { Expr } -Expr12 : Expr13 { $1 } - - -Property :: { Property } -Property : PropertyName ':' Expr { Prop $1 $3 } - - -ListProperty :: { [Property] } -ListProperty : {- empty -} { [] } - | Property { (:[]) $1 } - | Property ',' ListProperty { (:) $1 $3 } - - -PropertyName :: { PropertyName } -PropertyName : Ident { IdentPropName $1 } - | String { StringPropName $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 ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -eseq1_ x_ xs_ = ESeq (x_ : xs_) -} - diff --git a/src/GF/JavaScript/PrintJS.hs b/src/GF/JavaScript/PrintJS.hs deleted file mode 100644 index 66e78346e..000000000 --- a/src/GF/JavaScript/PrintJS.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.JavaScript.PrintJS (printTree, Doc, Print(..)) where - --- pretty-printer generated by the BNF converter - -import GF.JavaScript.AbsJS -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 - t:ts | not (spaceAfter t) -> showString t . rend i ts - t:ts@(t':_) | not (spaceBefore t') -> showString t . 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)) - -spaceAfter :: String -> Bool -spaceAfter = (`notElem` [".","(","[","{","\n"]) - -spaceBefore :: String -> Bool -spaceBefore = (`notElem` [",",".",":",";","(",")","[","]","{","}","\n"]) - -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 Program where - prt i e = case e of - Program elements -> prPrec i 0 (concatD [prt 0 elements]) - - -instance Print Element where - prt i e = case e of - FunDef id ids stmts -> prPrec i 0 (concatD [doc (showString "function") , prt 0 id , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")]) - ElStmt stmt -> prPrec i 0 (concatD [prt 0 stmt]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString "\n"), prt 0 xs]) -- HACKED! - -instance Print Stmt where - prt i e = case e of - SCompound stmts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stmts , doc (showString "}")]) - SReturnVoid -> prPrec i 0 (concatD [doc (showString "return") , doc (showString ";")]) - SReturn expr -> prPrec i 0 (concatD [doc (showString "return") , prt 0 expr , doc (showString ";")]) - SDeclOrExpr declorexpr -> prPrec i 0 (concatD [prt 0 declorexpr , doc (showString ";")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print DeclOrExpr where - prt i e = case e of - Decl declvars -> prPrec i 0 (concatD [doc (showString "var") , prt 0 declvars]) - DExpr expr -> prPrec i 0 (concatD [prt 1 expr]) - - -instance Print DeclVar where - prt i e = case e of - DVar id -> prPrec i 0 (concatD [prt 0 id]) - DInit id expr -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 expr]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Expr where - prt i e = case e of - EAssign expr0 expr -> prPrec i 13 (concatD [prt 14 expr0 , doc (showString "=") , prt 13 expr]) - ENew id exprs -> prPrec i 14 (concatD [doc (showString "new") , prt 0 id , doc (showString "(") , prt 0 exprs , doc (showString ")")]) - EMember expr id -> prPrec i 15 (concatD [prt 15 expr , doc (showString ".") , prt 0 id]) - EIndex expr0 expr -> prPrec i 15 (concatD [prt 15 expr0 , doc (showString "[") , prt 0 expr , doc (showString "]")]) - ECall expr exprs -> prPrec i 15 (concatD [prt 15 expr , doc (showString "(") , prt 0 exprs , doc (showString ")")]) - EVar id -> prPrec i 16 (concatD [prt 0 id]) - EInt n -> prPrec i 16 (concatD [prt 0 n]) - EDbl d -> prPrec i 16 (concatD [prt 0 d]) - EStr str -> prPrec i 16 (concatD [prt 0 str]) - ETrue -> prPrec i 16 (concatD [doc (showString "true")]) - EFalse -> prPrec i 16 (concatD [doc (showString "false")]) - ENull -> prPrec i 16 (concatD [doc (showString "null")]) - EThis -> prPrec i 16 (concatD [doc (showString "this")]) - EFun ids stmts -> prPrec i 16 (concatD [doc (showString "function") , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")]) - EArray exprs -> prPrec i 16 (concatD [doc (showString "[") , prt 0 exprs , doc (showString "]")]) - EObj propertys -> prPrec i 16 (concatD [doc (showString "{") , prt 0 propertys , doc (showString "}")]) - ESeq exprs -> prPrec i 16 (concatD [doc (showString "(") , prt 0 exprs , 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 Property where - prt i e = case e of - Prop propertyname expr -> prPrec i 0 (concatD [prt 0 propertyname , doc (showString ":") , prt 0 expr]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print PropertyName where - prt i e = case e of - IdentPropName id -> prPrec i 0 (concatD [prt 0 id]) - StringPropName str -> prPrec i 0 (concatD [prt 0 str]) - - - diff --git a/src/GF/JavaScript/SkelJS.hs b/src/GF/JavaScript/SkelJS.hs deleted file mode 100644 index f8cd588a7..000000000 --- a/src/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/GF/JavaScript/TestJS.hs b/src/GF/JavaScript/TestJS.hs deleted file mode 100644 index 3ddb52074..000000000 --- a/src/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/GF/OldParsing/CFGrammar.hs b/src/GF/OldParsing/CFGrammar.hs deleted file mode 100644 index 5a71fe0ab..000000000 --- a/src/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/GF/OldParsing/ConvertFiniteGFC.hs b/src/GF/OldParsing/ConvertFiniteGFC.hs deleted file mode 100644 index 25ed3fdb3..000000000 --- a/src/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/GF/OldParsing/ConvertFiniteSimple.hs b/src/GF/OldParsing/ConvertFiniteSimple.hs deleted file mode 100644 index a05092550..000000000 --- a/src/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/GF/OldParsing/ConvertGFCtoMCFG.hs b/src/GF/OldParsing/ConvertGFCtoMCFG.hs deleted file mode 100644 index c32812eb2..000000000 --- a/src/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/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs b/src/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs deleted file mode 100644 index 3ed6a3f48..000000000 --- a/src/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/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs b/src/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs deleted file mode 100644 index 7727aa15f..000000000 --- a/src/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/GF/OldParsing/ConvertGFCtoMCFG/Old.hs b/src/GF/OldParsing/ConvertGFCtoMCFG/Old.hs deleted file mode 100644 index 8b9b4a9ec..000000000 --- a/src/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/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs b/src/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs deleted file mode 100644 index d088bdebc..000000000 --- a/src/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/GF/OldParsing/ConvertGFCtoSimple.hs b/src/GF/OldParsing/ConvertGFCtoSimple.hs deleted file mode 100644 index 69a8b13c3..000000000 --- a/src/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/GF/OldParsing/ConvertGrammar.hs b/src/GF/OldParsing/ConvertGrammar.hs deleted file mode 100644 index 0dcd90770..000000000 --- a/src/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/GF/OldParsing/ConvertMCFGtoCFG.hs b/src/GF/OldParsing/ConvertMCFGtoCFG.hs deleted file mode 100644 index 58d141166..000000000 --- a/src/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/GF/OldParsing/ConvertSimpleToMCFG.hs b/src/GF/OldParsing/ConvertSimpleToMCFG.hs deleted file mode 100644 index e111444f9..000000000 --- a/src/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/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs b/src/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs deleted file mode 100644 index adc42115a..000000000 --- a/src/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/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs b/src/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs deleted file mode 100644 index 6627c5f2e..000000000 --- a/src/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/GF/OldParsing/ConvertSimpleToMCFG/Old.hs b/src/GF/OldParsing/ConvertSimpleToMCFG/Old.hs deleted file mode 100644 index dd2ff0713..000000000 --- a/src/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/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs b/src/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs deleted file mode 100644 index aa741518a..000000000 --- a/src/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/GF/OldParsing/GCFG.hs b/src/GF/OldParsing/GCFG.hs deleted file mode 100644 index 33a710e5d..000000000 --- a/src/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/GF/OldParsing/GeneralChart.hs b/src/GF/OldParsing/GeneralChart.hs deleted file mode 100644 index 1d51da025..000000000 --- a/src/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/GF/OldParsing/GrammarTypes.hs b/src/GF/OldParsing/GrammarTypes.hs deleted file mode 100644 index fc514fc75..000000000 --- a/src/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/GF/OldParsing/IncrementalChart.hs b/src/GF/OldParsing/IncrementalChart.hs deleted file mode 100644 index 132ed4dc4..000000000 --- a/src/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/GF/OldParsing/MCFGrammar.hs b/src/GF/OldParsing/MCFGrammar.hs deleted file mode 100644 index ff9d7de1b..000000000 --- a/src/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/GF/OldParsing/ParseCF.hs b/src/GF/OldParsing/ParseCF.hs deleted file mode 100644 index e1ef32aee..000000000 --- a/src/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/GF/OldParsing/ParseCFG.hs b/src/GF/OldParsing/ParseCFG.hs deleted file mode 100644 index 03c1d7dcc..000000000 --- a/src/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/GF/OldParsing/ParseCFG/General.hs b/src/GF/OldParsing/ParseCFG/General.hs deleted file mode 100644 index 438c89f1a..000000000 --- a/src/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/GF/OldParsing/ParseCFG/Incremental.hs b/src/GF/OldParsing/ParseCFG/Incremental.hs deleted file mode 100644 index f1bcde404..000000000 --- a/src/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/GF/OldParsing/ParseGFC.hs b/src/GF/OldParsing/ParseGFC.hs deleted file mode 100644 index fbc6cff5a..000000000 --- a/src/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/GF/OldParsing/ParseMCFG.hs b/src/GF/OldParsing/ParseMCFG.hs deleted file mode 100644 index c845a76b3..000000000 --- a/src/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/GF/OldParsing/ParseMCFG/Basic.hs b/src/GF/OldParsing/ParseMCFG/Basic.hs deleted file mode 100644 index baf7e4b2a..000000000 --- a/src/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/GF/OldParsing/SimpleGFC.hs b/src/GF/OldParsing/SimpleGFC.hs deleted file mode 100644 index 59f379bb4..000000000 --- a/src/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/GF/OldParsing/Utilities.hs b/src/GF/OldParsing/Utilities.hs deleted file mode 100644 index 6bacfe1fe..000000000 --- a/src/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/GF/Parsing/CF.hs b/src/GF/Parsing/CF.hs deleted file mode 100644 index 1a65f6caf..000000000 --- a/src/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/GF/Parsing/CFG.hs b/src/GF/Parsing/CFG.hs deleted file mode 100644 index f64ce55f1..000000000 --- a/src/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/GF/Parsing/CFG/General.hs b/src/GF/Parsing/CFG/General.hs deleted file mode 100644 index 4f5959a85..000000000 --- a/src/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/GF/Parsing/CFG/Incremental.hs b/src/GF/Parsing/CFG/Incremental.hs deleted file mode 100644 index adab2b73c..000000000 --- a/src/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/GF/Parsing/CFG/PInfo.hs b/src/GF/Parsing/CFG/PInfo.hs deleted file mode 100644 index f877b225e..000000000 --- a/src/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/GF/Parsing/FCFG.hs b/src/GF/Parsing/FCFG.hs deleted file mode 100644 index 30a7801c8..000000000 --- a/src/GF/Parsing/FCFG.hs +++ /dev/null @@ -1,100 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- FCFG parsing ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG - (parseFCF,buildFCFPInfo,FCFPInfo(..),makeFinalEdge) where - -import GF.Data.SortedList -import GF.Data.Assoc - -import GF.Infra.PrintClass - -import GF.Formalism.FCFG -import GF.Formalism.Utilities - -import qualified GF.Parsing.FCFG.Active as Active -import GF.Parsing.FCFG.PInfo - -import GF.GFCC.DataGFCC -import GF.GFCC.CId -import GF.GFCC.Macros -import GF.Data.ErrM - -import qualified Data.Map as Map - ----------------------------------------------------------------------- --- parsing - --- main parsing function - -parseFCF :: - String -> -- ^ parsing strategy - FCFPInfo -> -- ^ compiled grammar (fcfg) - CId -> -- ^ starting category - [String] -> -- ^ input tokens - Err [Exp] -- ^ resulting GF terms -parseFCF strategy pinfo startCat inString = - do let inTokens = input inString - startCats <- Map.lookup startCat (startupCats pinfo) - fcfParser <- {- trace lctree $ -} parseFCF strategy - let chart = fcfParser pinfo startCats inTokens - (i,j) = inputBounds inTokens - finalEdges = [makeFinalEdge cat i j | cat <- startCats] - forests = map cnv_forests $ chart2forests chart (const False) finalEdges - filteredForests = forests >>= applyProfileToForest - trees = nubsort $ filteredForests >>= forest2trees - return $ map tree2term trees - where - parseFCF :: String -> Err (FCFParser) - parseFCF "bottomup" = Ok $ Active.parse "b" - parseFCF "topdown" = Ok $ Active.parse "t" - parseFCF strat = Bad $ "FCFG parsing strategy not defined: " ++ strat - - -cnv_forests FMeta = FMeta -cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (CId 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 (CId 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 GFCC terms - -tree2term :: SyntaxTree CId -> Exp -tree2term (TNode f ts) = tree (AC f) (map tree2term ts) - -tree2term (TString s) = tree (AS s) [] -tree2term (TInt n) = tree (AI n) [] -tree2term (TFloat f) = tree (AF f) [] -tree2term (TMeta) = exp0 - ----------------------------------------------------------------------- --- conversion and unification of forests - --- simplest implementation -applyProfileToForest :: SyntaxForest FName -> [SyntaxForest CId] -applyProfileToForest (FNode name@(Name fun profile) children) - | isCoercionF 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] diff --git a/src/GF/Parsing/FCFG/Active.hs b/src/GF/Parsing/FCFG/Active.hs deleted file mode 100644 index df55793f8..000000000 --- a/src/GF/Parsing/FCFG/Active.hs +++ /dev/null @@ -1,179 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- MCFG parsing, the active algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG.Active (parse) where - -import GF.Data.GeneralDeduction -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Data.Utilities - -import GF.Formalism.FCFG -import GF.Formalism.Utilities - -import GF.Infra.PrintClass - -import GF.Parsing.FCFG.Range -import GF.Parsing.FCFG.PInfo - -import Control.Monad (guard) - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Array - ----------------------------------------------------------------------- --- * parsing - -parse :: String -> FCFParser -parse strategy pinfo starts toks = xchart2syntaxchart chart pinfo - where chart = process strategy pinfo toks axioms emptyXChart - axioms | isBU strategy = literals pinfo toks ++ initialBU pinfo toks - | isTD strategy = literals pinfo toks ++ initialTD pinfo starts toks - -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: RuleId -> FCFPInfo -> SyntaxNode RuleId RangeRec -emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) []) - where - FRule _ rhs _ _ = allRules pinfo ! ruleid - -process :: String -> FCFPInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat -process strategy pinfo toks [] chart = chart -process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks items $! univRule c item chart - where - univRule cat item@(Active found rng lbl ppos node@(SNode ruleid recs)) chart - | inRange (bounds lin) ppos = - case lin ! ppos of - FSymCat c r d -> case recs !! d of - [] -> case insertXChart chart item c of - Nothing -> chart - Just chart -> let items = do item@(Final found' _) <- lookupXChartFinal chart c - rng <- concatRange rng (found' !! r) - return (c, Active found rng lbl (ppos+1) (SNode ruleid (updateNth (const found') d recs))) - ++ - do guard (isTD strategy) - ruleid <- topdownRules pinfo ? c - return (c, Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) - in process strategy pinfo toks items chart - found' -> let items = do rng <- concatRange rng (found' !! r) - return (c, Active found rng lbl (ppos+1) node) - in process strategy pinfo toks items chart - FSymTok tok -> let items = do (i,j) <- inputToken toks ? tok - rng' <- concatRange rng (makeRange i j) - return (cat, Active found rng' lbl (ppos+1) node) - in process strategy pinfo toks items chart - | otherwise = - if inRange (bounds lins) (lbl+1) - then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart - else univRule cat (Final (reverse (rng:found)) node) chart - where - (FRule fn _ cat lins) = allRules pinfo ! ruleid - lin = lins ! lbl - univRule cat item@(Final found' node) chart = - case insertXChart chart item cat of - Nothing -> chart - Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat - let FRule _ _ _ lins = allRules pinfo ! ruleid - FSymCat cat r d = lins ! l ! ppos - rng <- concatRange rng (found' !! r) - return (cat, Active found rng l (ppos+1) (updateChildren node d found')) - ++ - do guard (isBU strategy) - ruleid <- leftcornerCats pinfo ? cat - let FRule _ _ _ lins = allRules pinfo ! ruleid - FSymCat cat r d = lins ! 0 ! 0 - return (cat, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found')) - - updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> SyntaxNode RuleId RangeRec - updateChildren (SNode ruleid recs) i rec = SNode ruleid $! updateNth (const rec) i recs - in process strategy pinfo toks items chart - ----------------------------------------------------------------------- --- * XChart - -data Item - = Active RangeRec - Range - {-# UNPACK #-} !FIndex - {-# UNPACK #-} !FPointPos - (SyntaxNode RuleId RangeRec) - | Final RangeRec (SyntaxNode RuleId RangeRec) - deriving (Eq, Ord) - -data XChart c = XChart !(ParseChart Item c) !(ParseChart Item c) - -emptyXChart :: Ord c => XChart c -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 - -xchart2syntaxchart :: XChart FCat -> FCFPInfo -> SyntaxChart FName (FCat,RangeRec) -xchart2syntaxchart (XChart actives finals) pinfo = - accumAssoc groupSyntaxNodes $ - [ case node of - SNode ruleid rrecs -> let FRule fun rhs cat _ = allRules pinfo ! ruleid - in ((cat,found), SNode fun (zip rhs rrecs)) - SString s -> ((cat,found), SString s) - SInt n -> ((cat,found), SInt n) - SFloat f -> ((cat,found), SFloat f) - | (cat, Final found node) <- chartAssocs finals - ] - -literals :: FCFPInfo -> Input FToken -> [(FCat,Item)] -literals pinfo toks = - [let (c,node) = lexer t in (c,Final [makeRange i j] node) | Edge i j t <- inputEdges toks, not (t `elem` grammarToks pinfo)] - where - lexer t = - case reads t of - [(n,"")] -> (fcatInt, SInt (n::Integer)) - _ -> case reads t of - [(f,"")] -> (fcatFloat, SFloat (f::Double)) - _ -> (fcatString,SString t) - - ----------------------------------------------------------------------- --- Earley -- - --- called with all starting categories -initialTD :: FCFPInfo -> [FCat] -> Input FToken -> [(FCat,Item)] -initialTD pinfo starts toks = - do cat <- starts - ruleid <- topdownRules pinfo ? cat - return (cat,Active [] (Range 0 0) 0 0 (emptyChildren ruleid pinfo)) - - ----------------------------------------------------------------------- --- Kilbury -- - -initialBU :: FCFPInfo -> Input FToken -> [(FCat,Item)] -initialBU pinfo toks = - do (tok,rngs) <- aAssocs (inputToken toks) - ruleid <- leftcornerTokens pinfo ? tok - let FRule _ _ cat _ = allRules pinfo ! ruleid - (i,j) <- rngs - return (cat,Active [] (makeRange i j) 0 1 (emptyChildren ruleid pinfo)) - ++ - do ruleid <- epsilonRules pinfo - let FRule _ _ cat _ = allRules pinfo ! ruleid - return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) diff --git a/src/GF/Parsing/FCFG/Incremental.hs b/src/GF/Parsing/FCFG/Incremental.hs deleted file mode 100644 index 5ee77a061..000000000 --- a/src/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/GF/Parsing/FCFG/PInfo.hs b/src/GF/Parsing/FCFG/PInfo.hs deleted file mode 100644 index 8b288f2f1..000000000 --- a/src/GF/Parsing/FCFG/PInfo.hs +++ /dev/null @@ -1,121 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- FCFG parsing, parser information ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG.PInfo where - -import GF.Infra.PrintClass -import GF.Formalism.Utilities -import GF.Formalism.FCFG -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Parsing.FCFG.Range -import qualified GF.GFCC.CId as AbsGFCC - -import Data.Array -import Data.Maybe -import qualified Data.Map as Map -import qualified Data.Set as Set -import Debug.Trace - ----------------------------------------------------------------------- --- type declarations - --- | the list of categories = possible starting categories -type FCFParser = FCFPInfo - -> [FCat] - -> Input FToken - -> SyntaxChart FName (FCat,RangeRec) - -makeFinalEdge cat 0 0 = (cat, [EmptyRange]) -makeFinalEdge cat i j = (cat, [makeRange i j]) - ------------------------------------------------------------- --- parser information - -type RuleId = Int - -data FCFPInfo - = FCFPInfo { allRules :: Array RuleId FRule - , topdownRules :: Assoc FCat (SList RuleId) - -- ^ used in 'GF.Parsing.MCFG.Active' (Earley): - -- , emptyRules :: [RuleId] - , epsilonRules :: [RuleId] - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , leftcornerCats :: Assoc FCat (SList RuleId) - , leftcornerTokens :: Assoc FToken (SList RuleId) - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , grammarCats :: SList FCat - , grammarToks :: SList FToken - , startupCats :: Map.Map AbsGFCC.CId [FCat] - } - - -getLeftCornerTok lins - | inRange (bounds syms) 0 = case syms ! 0 of - FSymTok tok -> Just tok - _ -> Nothing - | otherwise = Nothing - where - syms = lins ! 0 - -getLeftCornerCat lins - | inRange (bounds syms) 0 = case syms ! 0 of - FSymCat c _ _ -> Just c - _ -> Nothing - | otherwise = Nothing - where - syms = lins ! 0 - -buildFCFPInfo :: FGrammar -> FCFPInfo -buildFCFPInfo (grammar,startup) = -- trace (unlines [prt (x,Set.toList set) | (x,set) <- Map.toList leftcornFilter]) $ - FCFPInfo { allRules = allrules - , topdownRules = topdownrules - -- , emptyRules = emptyrules - , epsilonRules = epsilonrules - , leftcornerCats = leftcorncats - , leftcornerTokens = leftcorntoks - , grammarCats = grammarcats - , grammarToks = grammartoks - , startupCats = startup - } - - where allrules = listArray (0,length grammar-1) grammar - topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- assocs allrules] - -- emptyrules = [ruleid | (ruleid, FRule _ [] _ _) <- assocs allrules] - epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules, - not (inRange (bounds (lins ! 0)) 0) ] - leftcorncats = accumAssoc id - [ (fromJust (getLeftCornerCat lins), ruleid) | - (ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ] - leftcorntoks = accumAssoc id - [ (fromJust (getLeftCornerTok lins), ruleid) | - (ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ] - grammarcats = aElems topdownrules - grammartoks = nubsort [t | (FRule _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin] - -fcfPInfoToFGrammar :: FCFPInfo -> FGrammar -fcfPInfoToFGrammar pinfo = (elems (allRules pinfo), startupCats pinfo) - ----------------------------------------------------------------------- --- pretty-printing of statistics - -instance Print FCFPInfo where - prt pI = "[ allRules=" ++ sl (elems . allRules) ++ - "; tdRules=" ++ sla topdownRules ++ - -- "; emptyRules=" ++ sl emptyRules ++ - "; epsilonRules=" ++ sl epsilonRules ++ - "; lcCats=" ++ sla leftcornerCats ++ - "; lcTokens=" ++ sla leftcornerTokens ++ - "; categories=" ++ sl grammarCats ++ - " ]" - - 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/GF/Parsing/FCFG/Range.hs b/src/GF/Parsing/FCFG/Range.hs deleted file mode 100644 index 24674f58b..000000000 --- a/src/GF/Parsing/FCFG/Range.hs +++ /dev/null @@ -1,50 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Definitions of ranges, and operations on ranges ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG.Range - ( RangeRec, Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange, - ) where - - --- GF modules -import GF.Formalism.Utilities -import GF.Infra.PrintClass - ------------------------------------------------------------- --- ranges as single pairs - -type RangeRec = [Range] - -data Range = Range {-# UNPACK #-} !Int {-# UNPACK #-} !Int - | EmptyRange - deriving (Eq, Ord) - -makeRange :: Int -> Int -> Range -makeRange = Range - -concatRange :: Range -> Range -> [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 -> Edge a -rangeEdge a (Range i j) = Edge i j a - -edgeRange :: Edge a -> Range -edgeRange (Edge i j _) = Range i j - -minRange :: Range -> Int -minRange (Range i j) = i - -maxRange :: Range -> Int -maxRange (Range i j) = j - -instance Print Range where - prt (Range i j) = "(" ++ show i ++ "-" ++ show j ++ ")" - prt (EmptyRange) = "(?)" diff --git a/src/GF/Parsing/GFC.hs b/src/GF/Parsing/GFC.hs deleted file mode 100644 index 9f1328a50..000000000 --- a/src/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/GF/Parsing/MCFG.hs b/src/GF/Parsing/MCFG.hs deleted file mode 100644 index bda3af675..000000000 --- a/src/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/GF/Parsing/MCFG/Active.hs b/src/GF/Parsing/MCFG/Active.hs deleted file mode 100644 index c6e9c6b06..000000000 --- a/src/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/GF/Parsing/MCFG/Active2.hs b/src/GF/Parsing/MCFG/Active2.hs deleted file mode 100644 index 7ad8627bc..000000000 --- a/src/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/GF/Parsing/MCFG/FastActive.hs b/src/GF/Parsing/MCFG/FastActive.hs deleted file mode 100644 index 0a8e24b55..000000000 --- a/src/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/GF/Parsing/MCFG/Incremental.hs b/src/GF/Parsing/MCFG/Incremental.hs deleted file mode 100644 index bd5b4114d..000000000 --- a/src/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/GF/Parsing/MCFG/Incremental2.hs b/src/GF/Parsing/MCFG/Incremental2.hs deleted file mode 100644 index db6c3084e..000000000 --- a/src/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/GF/Parsing/MCFG/Naive.hs b/src/GF/Parsing/MCFG/Naive.hs deleted file mode 100644 index 7d1fa0a8a..000000000 --- a/src/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/GF/Parsing/MCFG/PInfo.hs b/src/GF/Parsing/MCFG/PInfo.hs deleted file mode 100644 index 56119dcec..000000000 --- a/src/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/GF/Parsing/MCFG/Range.hs b/src/GF/Parsing/MCFG/Range.hs deleted file mode 100644 index 91671fa00..000000000 --- a/src/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/GF/Parsing/MCFG/ViaCFG.hs b/src/GF/Parsing/MCFG/ViaCFG.hs deleted file mode 100644 index 9204ea9f1..000000000 --- a/src/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/GF/Printing/PrintParser.hs b/src/GF/Printing/PrintParser.hs deleted file mode 100644 index d9041ecaa..000000000 --- a/src/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/GF/Printing/PrintSimplifiedTerm.hs b/src/GF/Printing/PrintSimplifiedTerm.hs deleted file mode 100644 index ccd107558..000000000 --- a/src/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/GF/Probabilistic/Probabilistic.hs b/src/GF/Probabilistic/Probabilistic.hs deleted file mode 100644 index 25258db52..000000000 --- a/src/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/GF/Shell.hs b/src/GF/Shell.hs deleted file mode 100644 index 1d723bc62..000000000 --- a/src/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/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs deleted file mode 100644 index efb6460b4..000000000 --- a/src/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/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs deleted file mode 100644 index 8699c2fe7..000000000 --- a/src/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/GF/Shell/HelpFile.hs b/src/GF/Shell/HelpFile.hs deleted file mode 100644 index 43fae7c42..000000000 --- a/src/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/GF/Shell/JGF.hs b/src/GF/Shell/JGF.hs deleted file mode 100644 index 0ff678809..000000000 --- a/src/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/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs deleted file mode 100644 index 68cb4d629..000000000 --- a/src/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/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs deleted file mode 100644 index 70238817b..000000000 --- a/src/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/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs deleted file mode 100644 index 5ef0459e5..000000000 --- a/src/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/GF/Shell/TeachYourself.hs b/src/GF/Shell/TeachYourself.hs deleted file mode 100644 index 7e5a8afe2..000000000 --- a/src/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/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs deleted file mode 100644 index 63cc43006..000000000 --- a/src/GF/Source/AbsGF.hs +++ /dev/null @@ -1,306 +0,0 @@ -module GF.Source.AbsGF where - --- Haskell module generated by the BNF converter - -newtype LString = LString String deriving (Eq,Ord,Show) -newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show) -data Grammar = - Gr [ModDef] - deriving (Eq,Ord,Show) - -data ModDef = - MMain PIdent PIdent [ConcSpec] - | MModule ComplMod ModType ModBody - deriving (Eq,Ord,Show) - -data ConcSpec = - ConcSpec PIdent ConcExp - deriving (Eq,Ord,Show) - -data ConcExp = - ConcExp PIdent [Transfer] - deriving (Eq,Ord,Show) - -data Transfer = - TransferIn Open - | TransferOut Open - deriving (Eq,Ord,Show) - -data ModType = - MTAbstract PIdent - | MTResource PIdent - | MTInterface PIdent - | MTConcrete PIdent PIdent - | MTInstance PIdent PIdent - | MTTransfer PIdent Open Open - 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 - | OQualQO QualOpen PIdent - | OQual QualOpen PIdent PIdent - deriving (Eq,Ord,Show) - -data ComplMod = - CMCompl - | CMIncompl - deriving (Eq,Ord,Show) - -data QualOpen = - QOCompl - | QOIncompl - | QOInterface - deriving (Eq,Ord,Show) - -data Included = - IAll PIdent - | ISome PIdent [PIdent] - | IMinus PIdent [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 TopDef = - DefCat [CatDef] - | DefFun [FunDef] - | DefFunData [FunDef] - | DefDef [Def] - | DefData [DataDef] - | DefTrans [Def] - | DefPar [ParDef] - | DefOper [Def] - | DefLincat [PrintDef] - | DefLindef [Def] - | DefLin [Def] - | DefPrintCat [PrintDef] - | DefPrintFun [PrintDef] - | DefFlag [FlagDef] - | DefPrintOld [PrintDef] - | DefLintype [Def] - | DefPattern [Def] - | DefPackage PIdent [TopDef] - | DefVars [Def] - | DefTokenizer PIdent - deriving (Eq,Ord,Show) - -data CatDef = - SimpleCatDef PIdent [DDecl] - | ListCatDef PIdent [DDecl] - | ListSizeCatDef PIdent [DDecl] Integer - deriving (Eq,Ord,Show) - -data FunDef = - FunDef [PIdent] Exp - deriving (Eq,Ord,Show) - -data DataDef = - DataDef PIdent [DataConstr] - deriving (Eq,Ord,Show) - -data DataConstr = - DataId PIdent - | DataQId PIdent PIdent - deriving (Eq,Ord,Show) - -data ParDef = - ParDefDir PIdent [ParConstr] - | ParDefIndir PIdent PIdent - | ParDefAbs PIdent - deriving (Eq,Ord,Show) - -data ParConstr = - ParConstr PIdent [DDecl] - deriving (Eq,Ord,Show) - -data PrintDef = - PrintDef [Name] Exp - deriving (Eq,Ord,Show) - -data FlagDef = - FlagDef PIdent PIdent - deriving (Eq,Ord,Show) - -data Name = - IdentName 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 = - EIdent 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] - | EConAt PIdent 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 = - LIdent 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 = - BIdent 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 - | FIdent PIdent - | FSlash FileName - | FDot FileName - | FMinus FileName - | FAddId PIdent FileName - deriving (Eq,Ord,Show) - diff --git a/src/GF/Source/ErrM.hs b/src/GF/Source/ErrM.hs deleted file mode 100644 index 63840758e..000000000 --- a/src/GF/Source/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.Source.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/GF/Source/GF.cf b/src/GF/Source/GF.cf deleted file mode 100644 index 364550e6f..000000000 --- a/src/GF/Source/GF.cf +++ /dev/null @@ -1,370 +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 "{-" "-}" ; - --- the top-level grammar - -Gr. Grammar ::= [ModDef] ; - --- semicolon after module is permitted but not obligatory - -terminator ModDef "" ; -_. ModDef ::= ModDef ";" ; - --- The $main$ multilingual grammar structure --% - -MMain. ModDef ::= "grammar" PIdent "=" "{" "abstract" "=" PIdent ";" [ConcSpec] "}" ;--% - -ConcSpec. ConcSpec ::= PIdent "=" ConcExp ;--% -separator ConcSpec ";" ;--% - -ConcExp. ConcExp ::= PIdent [Transfer] ;--% - -separator Transfer "" ;--% -TransferIn. Transfer ::= "(" "transfer" "in" Open ")" ; --% -TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ; --% - --- the module header - -MModule2. ModHeader ::= ComplMod ModType "=" ModHeaderBody ; - -MBody2. ModHeaderBody ::= Extend Opens ; -MNoBody2. ModHeaderBody ::= [Included] ; -MWith2. ModHeaderBody ::= Included "with" [Open] ; -MWithBody2. ModHeaderBody ::= Included "with" [Open] "**" Opens ; -MWithE2. ModHeaderBody ::= [Included] "**" Included "with" [Open] ; -MWithEBody2. ModHeaderBody ::= [Included] "**" Included "with" [Open] "**" Opens ; - -MReuse2. ModHeaderBody ::= "reuse" PIdent ; --% -MUnion2. ModHeaderBody ::= "union" [Included] ;--% - --- the individual modules - -MModule. ModDef ::= ComplMod ModType "=" ModBody ; - -MTAbstract. ModType ::= "abstract" PIdent ; -MTResource. ModType ::= "resource" PIdent ; -MTInterface. ModType ::= "interface" PIdent ; -MTConcrete. ModType ::= "concrete" PIdent "of" PIdent ; -MTInstance. ModType ::= "instance" PIdent "of" PIdent ; -MTTransfer. ModType ::= "transfer" PIdent ":" Open "->" Open ; - - -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 ::= "(" QualOpen PIdent ")" ; -OQual. Open ::= "(" QualOpen PIdent "=" PIdent ")" ; - -CMCompl. ComplMod ::= ; -CMIncompl. ComplMod ::= "incomplete" ; - -QOCompl. QualOpen ::= ; -QOIncompl. QualOpen ::= "incomplete" ;--% -QOInterface. QualOpen ::= "interface" ;--% - -separator Included "," ; - -IAll. Included ::= PIdent ; -ISome. Included ::= PIdent "[" [PIdent] "]" ; -IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; - --- definitions after the $oper$ keywords - -DDecl. Def ::= [Name] ":" Exp ; -DDef. Def ::= [Name] "=" Exp ; -DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list -DFull. Def ::= [Name] ":" Exp "=" Exp ; - --- top-level definitions - -DefCat. TopDef ::= "cat" [CatDef] ; -DefFun. TopDef ::= "fun" [FunDef] ; -DefFunData.TopDef ::= "data" [FunDef] ; -DefDef. TopDef ::= "def" [Def] ; -DefData. TopDef ::= "data" [DataDef] ; - -DefTrans. TopDef ::= "transfer" [Def] ;--% - -DefPar. TopDef ::= "param" [ParDef] ; -DefOper. TopDef ::= "oper" [Def] ; - -DefLincat. TopDef ::= "lincat" [PrintDef] ; -DefLindef. TopDef ::= "lindef" [Def] ; -DefLin. TopDef ::= "lin" [Def] ; - -DefPrintCat. TopDef ::= "printname" "cat" [PrintDef] ; -DefPrintFun. TopDef ::= "printname" "fun" [PrintDef] ; -DefFlag. TopDef ::= "flags" [FlagDef] ; - -SimpleCatDef. CatDef ::= PIdent [DDecl] ; -ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; -ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; - -FunDef. FunDef ::= [PIdent] ":" Exp ; - -DataDef. DataDef ::= PIdent "=" [DataConstr] ; -DataId. DataConstr ::= PIdent ; -DataQId. DataConstr ::= PIdent "." PIdent ; -separator DataConstr "|" ; - - -ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; -ParDefIndir. ParDef ::= PIdent "=" "(" "in" PIdent ")" ; -ParDefAbs. ParDef ::= PIdent ; - -ParConstr. ParConstr ::= PIdent [DDecl] ; - -PrintDef. PrintDef ::= [Name] "=" Exp ; - -FlagDef. FlagDef ::= PIdent "=" PIdent ; - -terminator nonempty Def ";" ; -terminator nonempty CatDef ";" ; -terminator nonempty FunDef ";" ; -terminator nonempty DataDef ";" ; -terminator nonempty ParDef ";" ; - -terminator nonempty PrintDef ";" ; -terminator nonempty FlagDef ";" ; - -separator ParConstr "|" ; - -separator nonempty PIdent "," ; - --- names of categories and functions in definition LHS - -IdentName. 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 - -EIdent. 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] "}" ; ---- EPreCase. Exp4 ::= "pre" "{" [Case] "}" ; -EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; -EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; -EConAt. Exp4 ::= PIdent "@" Exp6 ; --% - -EPatt. Exp4 ::= "#" Patt2 ; -EPattType. Exp4 ::= "pattern" 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 - -LIdent. 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 - -BIdent. 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 ";" ; --% - -FIdent. 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" [PrintDef] ; --% -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 ";" ; --% - --- identifiers - -position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ; diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs deleted file mode 100644 index 6d48e4ced..000000000 --- a/src/GF/Source/GrammarToSource.hs +++ /dev/null @@ -1,259 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToSource --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/04 11:05:07 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.23 $ --- --- From internal source syntax to BNFC-generated (used for printing). ------------------------------------------------------------------------------ - -module GF.Source.GrammarToSource ( trGrammar, - trModule, - trAnyDef, - trLabel, - trt, tri, trp - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Modules -import GF.Infra.Option -import qualified GF.Source.AbsGF as P -import GF.Infra.Ident - --- | AR 13\/5\/2003 --- --- translate internal to parsable and printable source -trGrammar :: SourceGrammar -> P.Grammar -trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes - -trModule :: (Ident,SourceModInfo) -> P.ModDef -trModule (i,mo) = case mo of - ModMod m -> P.MModule compl typ body where - compl = case mstatus m of - MSIncomplete -> P.CMIncompl - _ -> P.CMCompl - i' = tri i - typ = case typeOfModule mo of - MTResource -> P.MTResource i' - MTAbstract -> P.MTAbstract i' - MTConcrete a -> P.MTConcrete i' (tri a) - MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b) - MTInstance a -> P.MTInstance i' (tri a) - MTInterface -> P.MTInterface i' - body = P.MBody - (trExtends (extend m)) - (mkOpens (map trOpen (opens m))) - (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m))) - -trExtends :: [(Ident,MInclude Ident)] -> 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) - ----- this has to be completed with other mtys -forName (MTConcrete a) = tri a - -trOpen :: OpenSpec Ident -> P.Open -trOpen o = case o of - OSimple OQNormal i -> P.OName (tri i) - OSimple q i -> P.OQualQO (trQualOpen q) (tri i) - OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j) - -trQualOpen q = case q of - OQNormal -> P.QOCompl - OQIncomplete -> P.QOIncompl - OQInterface -> P.QOInterface - - -mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds -mkTopDefs ds = ds - -trAnyDef :: (Ident,Info) -> [P.TopDef] -trAnyDef (i,info) = let i' = tri i in case info of - AbsCat (Yes co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]] - AbsFun (Yes ty) (Yes EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]] - AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of - Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] - _ -> [] - AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] - ---- don't destroy definitions! - AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]] - - ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] - ResParam pp -> [P.DefPar [case pp of - Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] - May b -> P.ParDefIndir i' $ tri b - _ -> P.ParDefAbs i']] - - ResOverload tysts -> - [P.DefOper [P.DDef [mkName i'] ( - P.EApp (P.EIdent $ tri $ identC "overload") - (P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]))]] - - CncCat (Yes ty) Nope _ -> - [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]] - CncCat pty ptr ppr -> - [P.DefLindef [trDef i' pty ptr]] ++ - [P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]] - CncFun _ ptr ppr -> - [P.DefLin [trDef i' nope ptr]] ++ - [P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]] -{- - ---- encoding of AnyInd without changing syntax. AR 20/9/2007 - AnyInd s b -> - [P.DefOper [P.DDef [mkName i] - (P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]] --} - _ -> [] - - -trDef :: P.PIdent -> Perh Type -> Perh Term -> P.Def -trDef i pty ptr = case (pty,ptr) of - (Nope, Nope) -> P.DDef [mkName i] (P.EMeta) --- - (_, Nope) -> P.DDecl [mkName i] (trPerh pty) - (Nope, _ ) -> P.DDef [mkName i] (trPerh ptr) - (_, _ ) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr) - -trPerh p = case p of - Yes t -> trt t - May b -> P.EIndir $ tri b - _ -> P.EMeta --- - - -trFlag :: Option -> P.TopDef -trFlag o = case o of - Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC f) (tri $ identC x)] - _ -> P.DefFlag [] --- warning? - -trt :: Term -> P.Exp -trt trm = case trm of - Vr s -> P.EIdent $ 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) - TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc) - TSh (TTyped ty) cc -> P.ETTable (trt ty) (map trCases cc) - TSh (TWild ty) cc -> P.ETTable (trt ty) (map trCases cc) - 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) - - Table x v -> P.ETType (trt x) (trt v) - S f x -> P.ESelect (trt f) (trt x) ----- Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t --- Alias c a t -> prt (Let (c,(Just a,t)) (Vr c)) -- thus Alias is only internal - - 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 - Strs tt -> P.EStrs $ map trt tt - EData -> P.EData - _ -> error $ "not yet" +++ show trm ---- - -trp :: Patt -> P.Patt -trp p = case p of - 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 [tri $ 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) - PChar -> P.PChar - PChars s -> P.PChars s - PM m c -> P.PM (tri m) (tri c) - - -trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty - where - t' = trt t - x = [tri $ trLabelIdent lab] - -trLabelling (lab,ty) = P.LDDecl [tri $ 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 = ppIdent . prIdent - -ppIdent i = P.PIdent ((0,0),i) - -trb i = if isWildIdent i then P.BWild else P.BIdent (tri i) - -trLabel :: Label -> P.Label -trLabel i = case i of - LIdent s -> P.LIdent $ ppIdent s - LVar i -> P.LVar $ toInteger i - -trLabelIdent i = identC $ case i of - LIdent s -> s - LVar i -> "v" ++ show i --- should not happen - -mkName :: P.PIdent -> P.Name -mkName = P.IdentName diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs deleted file mode 100644 index 89067b6b6..000000000 --- a/src/GF/Source/LexGF.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "GF/Source/LexGF.x" #-} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Source.LexGF where - - -import qualified Data.ByteString.Char8 as BS - -#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\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\x00\x00\x0c\x03\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\x14\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\x13\x00\x13\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\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x1b\x00\xff\xff\x00\x00\x00\x00\x17\x00\x1b\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\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\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x1c\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\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\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1c\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x17\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\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# "\x16\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\x15\x00\x15\x00\xff\xff\xff\xff\xff\xff\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_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_7))],[],[],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[],[],[]] -{-# LINE 36 "GF/Source/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_LString !String - | T_PIdent !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_LString s) -> s - PT _ (T_PIdent 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 "lincat" (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 "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" 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 "transfer" (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 - BS.ByteString) -- current input string - -tokens :: BS.ByteString -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: AlexInput -> [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 (BS.unpack (BS.take len str)) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p,_,cs) | BS.null cs = Nothing - | otherwise = let c = BS.head cs - cs' = BS.tail cs - p' = alexMove p c - in p' `seq` cs' `seq` Just (c, (p', c, cs')) - -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_LString . share) s)) -alex_action_5 = tok (\p s -> PT p (eitherResIdent (T_PIdent . 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/GF/Source/LexGF.x b/src/GF/Source/LexGF.x deleted file mode 100644 index 7ea768e75..000000000 --- a/src/GF/Source/LexGF.x +++ /dev/null @@ -1,137 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -module LexGF where - -import ErrM -import SharedString -} - - -$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 - \; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/ - -:- -"--" [.]* ; -- Toss single line comments -"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; - -$white+ ; -@rsyms { tok (\p s -> PT p (TS $ share s)) } -\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . 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)) } -$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ 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 - | 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_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 "lincat" (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 "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" 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 "transfer" (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, _, _) -> 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/GF/Source/ParGF.hs b/src/GF/Source/ParGF.hs deleted file mode 100644 index 30f83eef6..000000000 --- a/src/GF/Source/ParGF.hs +++ /dev/null @@ -1,7845 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} - module GF.Source.ParGF (pGrammar, pModDef, pOldGrammar, pExp, pModHeader, myLexer) where --H -import GF.Source.AbsGF --H -import GF.Source.LexGF --H -import GF.Infra.Ident --H -import GF.Data.ErrM --H -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.17 - -data HappyAbsSyn - = HappyTerminal Token - | HappyErrorToken Int - | HappyAbsSyn8 (Integer) - | HappyAbsSyn9 (String) - | HappyAbsSyn10 (Double) - | HappyAbsSyn11 (LString) - | HappyAbsSyn12 (PIdent) - | HappyAbsSyn13 (Grammar) - | HappyAbsSyn14 ([ModDef]) - | HappyAbsSyn15 (ModDef) - | HappyAbsSyn16 (ConcSpec) - | HappyAbsSyn17 ([ConcSpec]) - | HappyAbsSyn18 (ConcExp) - | HappyAbsSyn19 ([Transfer]) - | HappyAbsSyn20 (Transfer) - | HappyAbsSyn22 (ModBody) - | HappyAbsSyn23 (ModType) - | HappyAbsSyn25 ([TopDef]) - | HappyAbsSyn26 (Extend) - | HappyAbsSyn27 ([Open]) - | HappyAbsSyn28 (Opens) - | HappyAbsSyn29 (Open) - | HappyAbsSyn30 (ComplMod) - | HappyAbsSyn31 (QualOpen) - | HappyAbsSyn32 ([Included]) - | HappyAbsSyn33 (Included) - | HappyAbsSyn34 (Def) - | HappyAbsSyn35 (TopDef) - | HappyAbsSyn36 (CatDef) - | HappyAbsSyn37 (FunDef) - | HappyAbsSyn38 (DataDef) - | HappyAbsSyn39 (DataConstr) - | HappyAbsSyn40 ([DataConstr]) - | HappyAbsSyn41 (ParDef) - | HappyAbsSyn42 (ParConstr) - | HappyAbsSyn43 (PrintDef) - | HappyAbsSyn44 (FlagDef) - | HappyAbsSyn45 ([Def]) - | HappyAbsSyn46 ([CatDef]) - | HappyAbsSyn47 ([FunDef]) - | HappyAbsSyn48 ([DataDef]) - | HappyAbsSyn49 ([ParDef]) - | HappyAbsSyn50 ([PrintDef]) - | HappyAbsSyn51 ([FlagDef]) - | HappyAbsSyn52 ([ParConstr]) - | HappyAbsSyn53 ([PIdent]) - | HappyAbsSyn54 (Name) - | HappyAbsSyn55 ([Name]) - | HappyAbsSyn56 (LocDef) - | HappyAbsSyn57 ([LocDef]) - | HappyAbsSyn58 (Exp) - | HappyAbsSyn65 ([Exp]) - | HappyAbsSyn66 (Exps) - | HappyAbsSyn67 (Patt) - | HappyAbsSyn70 (PattAss) - | HappyAbsSyn71 (Label) - | HappyAbsSyn72 (Sort) - | HappyAbsSyn73 ([PattAss]) - | HappyAbsSyn74 ([Patt]) - | HappyAbsSyn75 (Bind) - | HappyAbsSyn76 ([Bind]) - | HappyAbsSyn77 (Decl) - | HappyAbsSyn78 (TupleComp) - | HappyAbsSyn79 (PattTupleComp) - | HappyAbsSyn80 ([TupleComp]) - | HappyAbsSyn81 ([PattTupleComp]) - | HappyAbsSyn82 (Case) - | HappyAbsSyn83 ([Case]) - | HappyAbsSyn84 (Equation) - | HappyAbsSyn85 ([Equation]) - | HappyAbsSyn86 (Altern) - | HappyAbsSyn87 ([Altern]) - | HappyAbsSyn88 (DDecl) - | HappyAbsSyn89 ([DDecl]) - | HappyAbsSyn90 (OldGrammar) - | HappyAbsSyn91 (Include) - | HappyAbsSyn92 (FileName) - | HappyAbsSyn93 ([FileName]) - -type HappyReduction m = - Int# - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> m HappyAbsSyn - -action_0, - action_1, - action_2, - action_3, - action_4, - action_5, - action_6, - action_7, - action_8, - action_9, - action_10, - action_11, - action_12, - action_13, - action_14, - action_15, - action_16, - action_17, - action_18, - action_19, - action_20, - action_21, - action_22, - action_23, - action_24, - action_25, - action_26, - action_27, - action_28, - action_29, - action_30, - action_31, - action_32, - action_33, - action_34, - action_35, - action_36, - action_37, - action_38, - action_39, - action_40, - action_41, - action_42, - action_43, - action_44, - action_45, - action_46, - action_47, - action_48, - action_49, - action_50, - action_51, - action_52, - action_53, - action_54, - action_55, - action_56, - action_57, - action_58, - action_59, - action_60, - action_61, - action_62, - action_63, - action_64, - action_65, - action_66, - action_67, - action_68, - action_69, - action_70, - action_71, - action_72, - action_73, - action_74, - action_75, - action_76, - action_77, - action_78, - action_79, - action_80, - action_81, - action_82, - action_83, - action_84, - action_85, - action_86, - action_87, - action_88, - action_89, - action_90, - action_91, - action_92, - action_93, - action_94, - action_95, - action_96, - action_97, - action_98, - action_99, - action_100, - action_101, - action_102, - action_103, - action_104, - action_105, - action_106, - action_107, - action_108, - action_109, - action_110, - action_111, - action_112, - action_113, - action_114, - action_115, - action_116, - action_117, - action_118, - action_119, - action_120, - action_121, - action_122, - action_123, - action_124, - action_125, - action_126, - action_127, - action_128, - action_129, - action_130, - action_131, - action_132, - action_133, - action_134, - action_135, - action_136, - action_137, - action_138, - action_139, - action_140, - action_141, - action_142, - action_143, - action_144, - action_145, - action_146, - action_147, - action_148, - action_149, - action_150, - action_151, - action_152, - action_153, - action_154, - action_155, - action_156, - action_157, - action_158, - action_159, - action_160, - action_161, - action_162, - action_163, - action_164, - action_165, - action_166, - action_167, - action_168, - action_169, - action_170, - action_171, - action_172, - action_173, - action_174, - action_175, - action_176, - action_177, - action_178, - action_179, - action_180, - action_181, - action_182, - action_183, - action_184, - action_185, - action_186, - action_187, - action_188, - action_189, - action_190, - action_191, - action_192, - action_193, - action_194, - action_195, - action_196, - action_197, - action_198, - action_199, - action_200, - action_201, - action_202, - action_203, - action_204, - action_205, - action_206, - action_207, - action_208, - action_209, - action_210, - action_211, - action_212, - action_213, - action_214, - action_215, - action_216, - action_217, - action_218, - action_219, - action_220, - action_221, - action_222, - action_223, - action_224, - action_225, - action_226, - action_227, - action_228, - action_229, - action_230, - action_231, - action_232, - action_233, - action_234, - action_235, - action_236, - action_237, - action_238, - action_239, - action_240, - action_241, - action_242, - action_243, - action_244, - action_245, - action_246, - action_247, - action_248, - action_249, - action_250, - action_251, - action_252, - action_253, - action_254, - action_255, - action_256, - action_257, - action_258, - action_259, - action_260, - action_261, - action_262, - action_263, - action_264, - action_265, - action_266, - action_267, - action_268, - action_269, - action_270, - action_271, - action_272, - action_273, - action_274, - action_275, - action_276, - action_277, - action_278, - action_279, - action_280, - action_281, - action_282, - action_283, - action_284, - action_285, - action_286, - action_287, - action_288, - action_289, - action_290, - action_291, - action_292, - action_293, - action_294, - action_295, - action_296, - action_297, - action_298, - action_299, - action_300, - action_301, - action_302, - action_303, - action_304, - action_305, - action_306, - action_307, - action_308, - action_309, - action_310, - action_311, - action_312, - action_313, - action_314, - action_315, - action_316, - action_317, - action_318, - action_319, - action_320, - action_321, - action_322, - action_323, - action_324, - action_325, - action_326, - action_327, - action_328, - action_329, - action_330, - action_331, - action_332, - action_333, - action_334, - action_335, - action_336, - action_337, - action_338, - action_339, - action_340, - action_341, - action_342, - action_343, - action_344, - action_345, - action_346, - action_347, - action_348, - action_349, - action_350, - action_351, - action_352, - action_353, - action_354, - action_355, - action_356, - action_357, - action_358, - action_359, - action_360, - action_361, - action_362, - action_363, - action_364, - action_365, - action_366, - action_367, - action_368, - action_369, - action_370, - action_371, - action_372, - action_373, - action_374, - action_375, - action_376, - action_377, - action_378, - action_379, - action_380, - action_381, - action_382, - action_383, - action_384, - action_385, - action_386, - action_387, - action_388, - action_389, - action_390, - action_391, - action_392, - action_393, - action_394, - action_395, - action_396, - action_397, - action_398, - action_399, - action_400, - action_401, - action_402, - action_403, - action_404, - action_405, - action_406, - action_407, - action_408, - action_409, - action_410, - action_411, - action_412, - action_413, - action_414, - action_415, - action_416, - action_417, - action_418, - action_419, - action_420, - action_421, - action_422, - action_423, - action_424, - action_425, - action_426, - action_427, - action_428, - action_429, - action_430, - action_431, - action_432, - action_433, - action_434, - action_435, - action_436, - action_437, - action_438, - action_439, - action_440, - action_441, - action_442, - action_443, - action_444, - action_445, - action_446, - action_447, - action_448, - action_449, - action_450, - action_451, - action_452, - action_453, - action_454, - action_455, - action_456, - action_457, - action_458, - action_459, - action_460, - action_461, - action_462, - action_463, - action_464, - action_465, - action_466, - action_467, - action_468, - action_469, - action_470, - action_471, - action_472, - action_473, - action_474, - action_475, - action_476, - action_477, - action_478, - action_479, - action_480, - action_481, - action_482, - action_483, - action_484, - action_485, - action_486, - action_487, - action_488, - action_489, - action_490, - action_491, - action_492, - action_493, - action_494, - action_495, - action_496, - action_497, - action_498, - action_499, - action_500, - action_501, - action_502, - action_503, - action_504, - action_505, - action_506, - action_507, - action_508, - action_509, - action_510, - action_511, - action_512, - action_513, - action_514, - action_515, - action_516, - action_517, - action_518, - action_519, - action_520, - action_521, - action_522, - action_523, - action_524, - action_525, - action_526, - action_527, - action_528, - action_529, - action_530, - action_531, - action_532, - action_533, - action_534, - action_535, - action_536, - action_537, - action_538, - action_539, - action_540, - action_541, - action_542, - action_543, - action_544, - action_545, - action_546, - action_547 :: () => Int# -> HappyReduction (Err) - -happyReduce_5, - happyReduce_6, - happyReduce_7, - happyReduce_8, - happyReduce_9, - happyReduce_10, - happyReduce_11, - happyReduce_12, - happyReduce_13, - happyReduce_14, - happyReduce_15, - happyReduce_16, - happyReduce_17, - happyReduce_18, - happyReduce_19, - happyReduce_20, - happyReduce_21, - happyReduce_22, - happyReduce_23, - happyReduce_24, - happyReduce_25, - happyReduce_26, - happyReduce_27, - happyReduce_28, - happyReduce_29, - happyReduce_30, - happyReduce_31, - happyReduce_32, - happyReduce_33, - happyReduce_34, - happyReduce_35, - happyReduce_36, - happyReduce_37, - happyReduce_38, - happyReduce_39, - happyReduce_40, - happyReduce_41, - happyReduce_42, - happyReduce_43, - happyReduce_44, - happyReduce_45, - happyReduce_46, - happyReduce_47, - happyReduce_48, - happyReduce_49, - happyReduce_50, - happyReduce_51, - happyReduce_52, - happyReduce_53, - happyReduce_54, - happyReduce_55, - happyReduce_56, - happyReduce_57, - happyReduce_58, - happyReduce_59, - happyReduce_60, - happyReduce_61, - happyReduce_62, - happyReduce_63, - happyReduce_64, - happyReduce_65, - happyReduce_66, - happyReduce_67, - happyReduce_68, - happyReduce_69, - happyReduce_70, - happyReduce_71, - happyReduce_72, - happyReduce_73, - happyReduce_74, - happyReduce_75, - happyReduce_76, - happyReduce_77, - happyReduce_78, - happyReduce_79, - happyReduce_80, - happyReduce_81, - happyReduce_82, - happyReduce_83, - happyReduce_84, - happyReduce_85, - happyReduce_86, - happyReduce_87, - happyReduce_88, - happyReduce_89, - happyReduce_90, - happyReduce_91, - happyReduce_92, - happyReduce_93, - happyReduce_94, - happyReduce_95, - happyReduce_96, - happyReduce_97, - happyReduce_98, - happyReduce_99, - happyReduce_100, - happyReduce_101, - happyReduce_102, - happyReduce_103, - happyReduce_104, - happyReduce_105, - happyReduce_106, - happyReduce_107, - happyReduce_108, - happyReduce_109, - happyReduce_110, - happyReduce_111, - happyReduce_112, - happyReduce_113, - happyReduce_114, - happyReduce_115, - happyReduce_116, - happyReduce_117, - happyReduce_118, - happyReduce_119, - happyReduce_120, - happyReduce_121, - happyReduce_122, - happyReduce_123, - happyReduce_124, - happyReduce_125, - happyReduce_126, - happyReduce_127, - happyReduce_128, - happyReduce_129, - happyReduce_130, - happyReduce_131, - happyReduce_132, - happyReduce_133, - happyReduce_134, - happyReduce_135, - happyReduce_136, - happyReduce_137, - happyReduce_138, - happyReduce_139, - happyReduce_140, - happyReduce_141, - happyReduce_142, - happyReduce_143, - happyReduce_144, - happyReduce_145, - happyReduce_146, - happyReduce_147, - happyReduce_148, - happyReduce_149, - happyReduce_150, - happyReduce_151, - happyReduce_152, - happyReduce_153, - happyReduce_154, - happyReduce_155, - happyReduce_156, - happyReduce_157, - happyReduce_158, - happyReduce_159, - happyReduce_160, - happyReduce_161, - happyReduce_162, - happyReduce_163, - happyReduce_164, - happyReduce_165, - happyReduce_166, - happyReduce_167, - happyReduce_168, - happyReduce_169, - happyReduce_170, - happyReduce_171, - happyReduce_172, - happyReduce_173, - happyReduce_174, - happyReduce_175, - happyReduce_176, - happyReduce_177, - happyReduce_178, - happyReduce_179, - happyReduce_180, - happyReduce_181, - happyReduce_182, - happyReduce_183, - happyReduce_184, - happyReduce_185, - happyReduce_186, - happyReduce_187, - happyReduce_188, - happyReduce_189, - happyReduce_190, - happyReduce_191, - happyReduce_192, - happyReduce_193, - happyReduce_194, - happyReduce_195, - happyReduce_196, - happyReduce_197, - happyReduce_198, - happyReduce_199, - happyReduce_200, - happyReduce_201, - happyReduce_202, - happyReduce_203, - happyReduce_204, - happyReduce_205, - happyReduce_206, - happyReduce_207, - happyReduce_208, - happyReduce_209, - happyReduce_210, - happyReduce_211, - happyReduce_212, - happyReduce_213, - happyReduce_214, - happyReduce_215, - happyReduce_216, - happyReduce_217, - happyReduce_218, - happyReduce_219, - happyReduce_220, - happyReduce_221, - happyReduce_222, - happyReduce_223, - happyReduce_224, - happyReduce_225, - happyReduce_226, - happyReduce_227, - happyReduce_228, - happyReduce_229, - happyReduce_230, - happyReduce_231, - happyReduce_232, - happyReduce_233, - happyReduce_234, - happyReduce_235, - happyReduce_236, - happyReduce_237, - happyReduce_238, - happyReduce_239, - happyReduce_240, - happyReduce_241, - happyReduce_242, - happyReduce_243, - happyReduce_244, - happyReduce_245, - happyReduce_246, - happyReduce_247, - happyReduce_248, - happyReduce_249, - happyReduce_250, - happyReduce_251, - happyReduce_252, - happyReduce_253, - happyReduce_254, - happyReduce_255, - happyReduce_256, - happyReduce_257, - happyReduce_258, - happyReduce_259, - happyReduce_260, - happyReduce_261, - happyReduce_262, - happyReduce_263, - happyReduce_264, - happyReduce_265, - happyReduce_266, - happyReduce_267, - happyReduce_268, - happyReduce_269, - happyReduce_270, - happyReduce_271, - happyReduce_272, - happyReduce_273, - happyReduce_274 :: () => HappyReduction (Err) - -action_0 (13#) = happyGoto action_58 -action_0 (14#) = happyGoto action_59 -action_0 x = happyTcHack x happyReduce_11 - -action_1 (139#) = happyShift action_57 -action_1 (142#) = happyShift action_9 -action_1 (15#) = happyGoto action_55 -action_1 (30#) = happyGoto action_56 -action_1 x = happyTcHack x happyReduce_60 - -action_2 (141#) = happyShift action_54 -action_2 (90#) = happyGoto action_52 -action_2 (91#) = happyGoto action_53 -action_2 x = happyTcHack x happyReduce_265 - -action_3 (96#) = happyShift action_24 -action_3 (98#) = happyShift action_25 -action_3 (104#) = happyShift action_26 -action_3 (109#) = happyShift action_27 -action_3 (110#) = happyShift action_28 -action_3 (111#) = happyShift action_29 -action_3 (114#) = happyShift action_30 -action_3 (119#) = happyShift action_31 -action_3 (124#) = happyShift action_32 -action_3 (125#) = happyShift action_33 -action_3 (126#) = happyShift action_34 -action_3 (127#) = happyShift action_35 -action_3 (128#) = happyShift action_36 -action_3 (129#) = happyShift action_37 -action_3 (131#) = happyShift action_38 -action_3 (134#) = happyShift action_39 -action_3 (137#) = happyShift action_40 -action_3 (140#) = happyShift action_41 -action_3 (145#) = happyShift action_42 -action_3 (156#) = happyShift action_43 -action_3 (157#) = happyShift action_44 -action_3 (161#) = happyShift action_45 -action_3 (162#) = happyShift action_46 -action_3 (167#) = happyShift action_47 -action_3 (170#) = happyShift action_6 -action_3 (171#) = happyShift action_48 -action_3 (172#) = happyShift action_49 -action_3 (173#) = happyShift action_50 -action_3 (174#) = happyShift action_51 -action_3 (8#) = happyGoto action_10 -action_3 (9#) = happyGoto action_11 -action_3 (10#) = happyGoto action_12 -action_3 (11#) = happyGoto action_13 -action_3 (12#) = happyGoto action_14 -action_3 (58#) = happyGoto action_15 -action_3 (59#) = happyGoto action_16 -action_3 (60#) = happyGoto action_17 -action_3 (61#) = happyGoto action_18 -action_3 (62#) = happyGoto action_19 -action_3 (63#) = happyGoto action_20 -action_3 (64#) = happyGoto action_21 -action_3 (72#) = happyGoto action_22 -action_3 (77#) = happyGoto action_23 -action_3 x = happyTcHack x happyFail - -action_4 (142#) = happyShift action_9 -action_4 (21#) = happyGoto action_7 -action_4 (30#) = happyGoto action_8 -action_4 x = happyTcHack x happyReduce_60 - -action_5 (170#) = happyShift action_6 -action_5 x = happyTcHack x happyFail - -action_6 x = happyTcHack x happyReduce_5 - -action_7 (1#) = happyAccept -action_7 x = happyTcHack x happyFail - -action_8 (130#) = happyShift action_63 -action_8 (133#) = happyShift action_64 -action_8 (143#) = happyShift action_65 -action_8 (144#) = happyShift action_66 -action_8 (159#) = happyShift action_67 -action_8 (164#) = happyShift action_68 -action_8 (23#) = happyGoto action_137 -action_8 x = happyTcHack x happyFail - -action_9 x = happyTcHack x happyReduce_61 - -action_10 x = happyTcHack x happyReduce_145 - -action_11 x = happyTcHack x happyReduce_144 - -action_12 x = happyTcHack x happyReduce_146 - -action_13 x = happyTcHack x happyReduce_157 - -action_14 (113#) = happyShift action_136 -action_14 x = happyTcHack x happyReduce_140 - -action_15 x = happyTcHack x happyReduce_161 - -action_16 (107#) = happyShift action_135 -action_16 x = happyTcHack x happyReduce_173 - -action_17 (96#) = happyShift action_24 -action_17 (98#) = happyShift action_82 -action_17 (101#) = happyReduce_240 -action_17 (104#) = happyShift action_26 -action_17 (109#) = happyShift action_27 -action_17 (110#) = happyShift action_28 -action_17 (111#) = happyShift action_29 -action_17 (125#) = happyShift action_33 -action_17 (126#) = happyShift action_34 -action_17 (127#) = happyShift action_35 -action_17 (128#) = happyShift action_36 -action_17 (129#) = happyShift action_37 -action_17 (134#) = happyShift action_39 -action_17 (170#) = happyShift action_6 -action_17 (171#) = happyShift action_48 -action_17 (172#) = happyShift action_49 -action_17 (173#) = happyShift action_50 -action_17 (174#) = happyShift action_51 -action_17 (8#) = happyGoto action_10 -action_17 (9#) = happyGoto action_11 -action_17 (10#) = happyGoto action_12 -action_17 (11#) = happyGoto action_13 -action_17 (12#) = happyGoto action_79 -action_17 (58#) = happyGoto action_15 -action_17 (59#) = happyGoto action_134 -action_17 (72#) = happyGoto action_22 -action_17 x = happyTcHack x happyReduce_178 - -action_18 (102#) = happyShift action_129 -action_18 (115#) = happyShift action_130 -action_18 (116#) = happyShift action_131 -action_18 (120#) = happyShift action_132 -action_18 (168#) = happyShift action_133 -action_18 x = happyTcHack x happyReduce_192 - -action_19 (118#) = happyShift action_128 -action_19 x = happyTcHack x happyReduce_191 - -action_20 (176#) = happyAccept -action_20 x = happyTcHack x happyFail - -action_21 (117#) = happyShift action_127 -action_21 x = happyTcHack x happyReduce_180 - -action_22 x = happyTcHack x happyReduce_143 - -action_23 (101#) = happyShift action_126 -action_23 x = happyTcHack x happyFail - -action_24 (174#) = happyShift action_51 -action_24 (12#) = happyGoto action_124 -action_24 (53#) = happyGoto action_88 -action_24 (56#) = happyGoto action_89 -action_24 (57#) = happyGoto action_125 -action_24 x = happyTcHack x happyReduce_137 - -action_25 (96#) = happyShift action_24 -action_25 (98#) = happyShift action_25 -action_25 (104#) = happyShift action_26 -action_25 (109#) = happyShift action_27 -action_25 (110#) = happyShift action_28 -action_25 (111#) = happyShift action_29 -action_25 (114#) = happyShift action_30 -action_25 (119#) = happyShift action_31 -action_25 (121#) = happyShift action_100 -action_25 (124#) = happyShift action_32 -action_25 (125#) = happyShift action_33 -action_25 (126#) = happyShift action_34 -action_25 (127#) = happyShift action_35 -action_25 (128#) = happyShift action_36 -action_25 (129#) = happyShift action_37 -action_25 (131#) = happyShift action_38 -action_25 (134#) = happyShift action_39 -action_25 (137#) = happyShift action_40 -action_25 (140#) = happyShift action_123 -action_25 (145#) = happyShift action_42 -action_25 (156#) = happyShift action_43 -action_25 (157#) = happyShift action_44 -action_25 (161#) = happyShift action_45 -action_25 (162#) = happyShift action_46 -action_25 (167#) = happyShift action_47 -action_25 (170#) = happyShift action_6 -action_25 (171#) = happyShift action_48 -action_25 (172#) = happyShift action_49 -action_25 (173#) = happyShift action_50 -action_25 (174#) = happyShift action_51 -action_25 (8#) = happyGoto action_10 -action_25 (9#) = happyGoto action_11 -action_25 (10#) = happyGoto action_12 -action_25 (11#) = happyGoto action_13 -action_25 (12#) = happyGoto action_120 -action_25 (58#) = happyGoto action_15 -action_25 (59#) = happyGoto action_16 -action_25 (60#) = happyGoto action_17 -action_25 (61#) = happyGoto action_18 -action_25 (62#) = happyGoto action_19 -action_25 (63#) = happyGoto action_121 -action_25 (64#) = happyGoto action_21 -action_25 (72#) = happyGoto action_22 -action_25 (75#) = happyGoto action_97 -action_25 (76#) = happyGoto action_122 -action_25 (77#) = happyGoto action_23 -action_25 x = happyTcHack x happyReduce_236 - -action_26 (105#) = happyShift action_119 -action_26 (171#) = happyShift action_48 -action_26 (174#) = happyShift action_51 -action_26 (9#) = happyGoto action_117 -action_26 (12#) = happyGoto action_118 -action_26 x = happyTcHack x happyFail - -action_27 (174#) = happyShift action_51 -action_27 (12#) = happyGoto action_116 -action_27 x = happyTcHack x happyFail - -action_28 x = happyTcHack x happyReduce_147 - -action_29 (96#) = happyShift action_24 -action_29 (98#) = happyShift action_25 -action_29 (104#) = happyShift action_26 -action_29 (109#) = happyShift action_27 -action_29 (110#) = happyShift action_28 -action_29 (111#) = happyShift action_29 -action_29 (114#) = happyShift action_30 -action_29 (119#) = happyShift action_31 -action_29 (124#) = happyShift action_32 -action_29 (125#) = happyShift action_33 -action_29 (126#) = happyShift action_34 -action_29 (127#) = happyShift action_35 -action_29 (128#) = happyShift action_36 -action_29 (129#) = happyShift action_37 -action_29 (131#) = happyShift action_38 -action_29 (134#) = happyShift action_39 -action_29 (137#) = happyShift action_40 -action_29 (140#) = happyShift action_41 -action_29 (145#) = happyShift action_42 -action_29 (156#) = happyShift action_43 -action_29 (157#) = happyShift action_44 -action_29 (161#) = happyShift action_45 -action_29 (162#) = happyShift action_46 -action_29 (167#) = happyShift action_47 -action_29 (170#) = happyShift action_6 -action_29 (171#) = happyShift action_48 -action_29 (172#) = happyShift action_49 -action_29 (173#) = happyShift action_50 -action_29 (174#) = happyShift action_51 -action_29 (8#) = happyGoto action_10 -action_29 (9#) = happyGoto action_11 -action_29 (10#) = happyGoto action_12 -action_29 (11#) = happyGoto action_13 -action_29 (12#) = happyGoto action_14 -action_29 (58#) = happyGoto action_15 -action_29 (59#) = happyGoto action_16 -action_29 (60#) = happyGoto action_17 -action_29 (61#) = happyGoto action_18 -action_29 (62#) = happyGoto action_19 -action_29 (63#) = happyGoto action_113 -action_29 (64#) = happyGoto action_21 -action_29 (72#) = happyGoto action_22 -action_29 (77#) = happyGoto action_23 -action_29 (78#) = happyGoto action_114 -action_29 (80#) = happyGoto action_115 -action_29 x = happyTcHack x happyReduce_243 - -action_30 (96#) = happyShift action_106 -action_30 (98#) = happyShift action_107 -action_30 (104#) = happyShift action_108 -action_30 (110#) = happyShift action_109 -action_30 (111#) = happyShift action_110 -action_30 (114#) = happyShift action_111 -action_30 (121#) = happyShift action_112 -action_30 (170#) = happyShift action_6 -action_30 (171#) = happyShift action_48 -action_30 (172#) = happyShift action_49 -action_30 (174#) = happyShift action_51 -action_30 (8#) = happyGoto action_101 -action_30 (9#) = happyGoto action_102 -action_30 (10#) = happyGoto action_103 -action_30 (12#) = happyGoto action_104 -action_30 (67#) = happyGoto action_105 -action_30 x = happyTcHack x happyFail - -action_31 (119#) = happyShift action_99 -action_31 (121#) = happyShift action_100 -action_31 (174#) = happyShift action_51 -action_31 (12#) = happyGoto action_96 -action_31 (75#) = happyGoto action_97 -action_31 (76#) = happyGoto action_98 -action_31 x = happyTcHack x happyReduce_236 - -action_32 (174#) = happyShift action_51 -action_32 (12#) = happyGoto action_95 -action_32 x = happyTcHack x happyFail - -action_33 x = happyTcHack x happyReduce_225 - -action_34 x = happyTcHack x happyReduce_227 - -action_35 x = happyTcHack x happyReduce_228 - -action_36 x = happyTcHack x happyReduce_226 - -action_37 x = happyTcHack x happyReduce_224 - -action_38 (96#) = happyShift action_24 -action_38 (98#) = happyShift action_25 -action_38 (104#) = happyShift action_26 -action_38 (109#) = happyShift action_27 -action_38 (110#) = happyShift action_28 -action_38 (111#) = happyShift action_29 -action_38 (114#) = happyShift action_30 -action_38 (119#) = happyShift action_31 -action_38 (124#) = happyShift action_32 -action_38 (125#) = happyShift action_33 -action_38 (126#) = happyShift action_34 -action_38 (127#) = happyShift action_35 -action_38 (128#) = happyShift action_36 -action_38 (129#) = happyShift action_37 -action_38 (131#) = happyShift action_38 -action_38 (134#) = happyShift action_39 -action_38 (137#) = happyShift action_40 -action_38 (140#) = happyShift action_41 -action_38 (145#) = happyShift action_42 -action_38 (156#) = happyShift action_43 -action_38 (157#) = happyShift action_44 -action_38 (161#) = happyShift action_45 -action_38 (162#) = happyShift action_46 -action_38 (167#) = happyShift action_47 -action_38 (170#) = happyShift action_6 -action_38 (171#) = happyShift action_48 -action_38 (172#) = happyShift action_49 -action_38 (173#) = happyShift action_50 -action_38 (174#) = happyShift action_51 -action_38 (8#) = happyGoto action_10 -action_38 (9#) = happyGoto action_11 -action_38 (10#) = happyGoto action_12 -action_38 (11#) = happyGoto action_13 -action_38 (12#) = happyGoto action_14 -action_38 (58#) = happyGoto action_15 -action_38 (59#) = happyGoto action_16 -action_38 (60#) = happyGoto action_17 -action_38 (61#) = happyGoto action_18 -action_38 (62#) = happyGoto action_19 -action_38 (63#) = happyGoto action_94 -action_38 (64#) = happyGoto action_21 -action_38 (72#) = happyGoto action_22 -action_38 (77#) = happyGoto action_23 -action_38 x = happyTcHack x happyFail - -action_39 x = happyTcHack x happyReduce_149 - -action_40 (96#) = happyShift action_93 -action_40 x = happyTcHack x happyFail - -action_41 (96#) = happyShift action_24 -action_41 (98#) = happyShift action_82 -action_41 (104#) = happyShift action_26 -action_41 (109#) = happyShift action_27 -action_41 (110#) = happyShift action_28 -action_41 (111#) = happyShift action_29 -action_41 (125#) = happyShift action_33 -action_41 (126#) = happyShift action_34 -action_41 (127#) = happyShift action_35 -action_41 (128#) = happyShift action_36 -action_41 (129#) = happyShift action_37 -action_41 (134#) = happyShift action_39 -action_41 (170#) = happyShift action_6 -action_41 (171#) = happyShift action_48 -action_41 (172#) = happyShift action_49 -action_41 (173#) = happyShift action_50 -action_41 (174#) = happyShift action_51 -action_41 (8#) = happyGoto action_10 -action_41 (9#) = happyGoto action_11 -action_41 (10#) = happyGoto action_12 -action_41 (11#) = happyGoto action_13 -action_41 (12#) = happyGoto action_79 -action_41 (58#) = happyGoto action_15 -action_41 (59#) = happyGoto action_92 -action_41 (72#) = happyGoto action_22 -action_41 x = happyTcHack x happyFail - -action_42 (96#) = happyShift action_91 -action_42 (174#) = happyShift action_51 -action_42 (12#) = happyGoto action_87 -action_42 (53#) = happyGoto action_88 -action_42 (56#) = happyGoto action_89 -action_42 (57#) = happyGoto action_90 -action_42 x = happyTcHack x happyReduce_137 - -action_43 (96#) = happyShift action_24 -action_43 (98#) = happyShift action_82 -action_43 (104#) = happyShift action_26 -action_43 (109#) = happyShift action_27 -action_43 (110#) = happyShift action_28 -action_43 (111#) = happyShift action_29 -action_43 (125#) = happyShift action_33 -action_43 (126#) = happyShift action_34 -action_43 (127#) = happyShift action_35 -action_43 (128#) = happyShift action_36 -action_43 (129#) = happyShift action_37 -action_43 (134#) = happyShift action_39 -action_43 (170#) = happyShift action_6 -action_43 (171#) = happyShift action_48 -action_43 (172#) = happyShift action_49 -action_43 (173#) = happyShift action_50 -action_43 (174#) = happyShift action_51 -action_43 (8#) = happyGoto action_10 -action_43 (9#) = happyGoto action_11 -action_43 (10#) = happyGoto action_12 -action_43 (11#) = happyGoto action_13 -action_43 (12#) = happyGoto action_79 -action_43 (58#) = happyGoto action_15 -action_43 (59#) = happyGoto action_86 -action_43 (72#) = happyGoto action_22 -action_43 x = happyTcHack x happyFail - -action_44 (96#) = happyShift action_85 -action_44 x = happyTcHack x happyFail - -action_45 (96#) = happyShift action_84 -action_45 x = happyTcHack x happyFail - -action_46 (96#) = happyShift action_81 -action_46 (98#) = happyShift action_82 -action_46 (104#) = happyShift action_26 -action_46 (109#) = happyShift action_83 -action_46 (110#) = happyShift action_28 -action_46 (111#) = happyShift action_29 -action_46 (125#) = happyShift action_33 -action_46 (126#) = happyShift action_34 -action_46 (127#) = happyShift action_35 -action_46 (128#) = happyShift action_36 -action_46 (129#) = happyShift action_37 -action_46 (134#) = happyShift action_39 -action_46 (170#) = happyShift action_6 -action_46 (171#) = happyShift action_48 -action_46 (172#) = happyShift action_49 -action_46 (173#) = happyShift action_50 -action_46 (174#) = happyShift action_51 -action_46 (8#) = happyGoto action_10 -action_46 (9#) = happyGoto action_11 -action_46 (10#) = happyGoto action_12 -action_46 (11#) = happyGoto action_13 -action_46 (12#) = happyGoto action_79 -action_46 (58#) = happyGoto action_80 -action_46 (72#) = happyGoto action_22 -action_46 x = happyTcHack x happyFail - -action_47 (96#) = happyShift action_78 -action_47 x = happyTcHack x happyFail - -action_48 x = happyTcHack x happyReduce_6 - -action_49 x = happyTcHack x happyReduce_7 - -action_50 x = happyTcHack x happyReduce_8 - -action_51 x = happyTcHack x happyReduce_9 - -action_52 (176#) = happyAccept -action_52 x = happyTcHack x happyFail - -action_53 (25#) = happyGoto action_77 -action_53 x = happyTcHack x happyReduce_48 - -action_54 (106#) = happyShift action_74 -action_54 (107#) = happyShift action_75 -action_54 (123#) = happyShift action_76 -action_54 (171#) = happyShift action_48 -action_54 (174#) = happyShift action_51 -action_54 (9#) = happyGoto action_70 -action_54 (12#) = happyGoto action_71 -action_54 (92#) = happyGoto action_72 -action_54 (93#) = happyGoto action_73 -action_54 x = happyTcHack x happyFail - -action_55 (94#) = happyShift action_69 -action_55 (176#) = happyAccept -action_55 x = happyTcHack x happyFail - -action_56 (130#) = happyShift action_63 -action_56 (133#) = happyShift action_64 -action_56 (143#) = happyShift action_65 -action_56 (144#) = happyShift action_66 -action_56 (159#) = happyShift action_67 -action_56 (164#) = happyShift action_68 -action_56 (23#) = happyGoto action_62 -action_56 x = happyTcHack x happyFail - -action_57 (174#) = happyShift action_51 -action_57 (12#) = happyGoto action_61 -action_57 x = happyTcHack x happyFail - -action_58 (176#) = happyAccept -action_58 x = happyTcHack x happyFail - -action_59 (139#) = happyShift action_57 -action_59 (142#) = happyShift action_9 -action_59 (176#) = happyReduce_10 -action_59 (15#) = happyGoto action_60 -action_59 (30#) = happyGoto action_56 -action_59 x = happyTcHack x happyReduce_60 - -action_60 (94#) = happyShift action_69 -action_60 x = happyTcHack x happyReduce_12 - -action_61 (95#) = happyShift action_239 -action_61 x = happyTcHack x happyFail - -action_62 (95#) = happyShift action_238 -action_62 x = happyTcHack x happyFail - -action_63 (174#) = happyShift action_51 -action_63 (12#) = happyGoto action_237 -action_63 x = happyTcHack x happyFail - -action_64 (174#) = happyShift action_51 -action_64 (12#) = happyGoto action_236 -action_64 x = happyTcHack x happyFail - -action_65 (174#) = happyShift action_51 -action_65 (12#) = happyGoto action_235 -action_65 x = happyTcHack x happyFail - -action_66 (174#) = happyShift action_51 -action_66 (12#) = happyGoto action_234 -action_66 x = happyTcHack x happyFail - -action_67 (174#) = happyShift action_51 -action_67 (12#) = happyGoto action_233 -action_67 x = happyTcHack x happyFail - -action_68 (174#) = happyShift action_51 -action_68 (12#) = happyGoto action_232 -action_68 x = happyTcHack x happyFail - -action_69 x = happyTcHack x happyReduce_13 - -action_70 x = happyTcHack x happyReduce_267 - -action_71 (106#) = happyShift action_74 -action_71 (107#) = happyShift action_75 -action_71 (123#) = happyShift action_76 -action_71 (171#) = happyShift action_48 -action_71 (174#) = happyShift action_51 -action_71 (9#) = happyGoto action_70 -action_71 (12#) = happyGoto action_71 -action_71 (92#) = happyGoto action_231 -action_71 x = happyTcHack x happyReduce_268 - -action_72 (94#) = happyShift action_230 -action_72 x = happyTcHack x happyFail - -action_73 x = happyTcHack x happyReduce_266 - -action_74 (106#) = happyShift action_74 -action_74 (107#) = happyShift action_75 -action_74 (123#) = happyShift action_76 -action_74 (171#) = happyShift action_48 -action_74 (174#) = happyShift action_51 -action_74 (9#) = happyGoto action_70 -action_74 (12#) = happyGoto action_71 -action_74 (92#) = happyGoto action_229 -action_74 x = happyTcHack x happyFail - -action_75 (106#) = happyShift action_74 -action_75 (107#) = happyShift action_75 -action_75 (123#) = happyShift action_76 -action_75 (171#) = happyShift action_48 -action_75 (174#) = happyShift action_51 -action_75 (9#) = happyGoto action_70 -action_75 (12#) = happyGoto action_71 -action_75 (92#) = happyGoto action_228 -action_75 x = happyTcHack x happyFail - -action_76 (106#) = happyShift action_74 -action_76 (107#) = happyShift action_75 -action_76 (123#) = happyShift action_76 -action_76 (171#) = happyShift action_48 -action_76 (174#) = happyShift action_51 -action_76 (9#) = happyGoto action_70 -action_76 (12#) = happyGoto action_71 -action_76 (92#) = happyGoto action_227 -action_76 x = happyTcHack x happyFail - -action_77 (132#) = happyShift action_210 -action_77 (134#) = happyShift action_211 -action_77 (135#) = happyShift action_212 -action_77 (136#) = happyShift action_213 -action_77 (138#) = happyShift action_214 -action_77 (146#) = happyShift action_215 -action_77 (147#) = happyShift action_216 -action_77 (148#) = happyShift action_217 -action_77 (149#) = happyShift action_218 -action_77 (152#) = happyShift action_219 -action_77 (154#) = happyShift action_220 -action_77 (155#) = happyShift action_221 -action_77 (156#) = happyShift action_222 -action_77 (158#) = happyShift action_223 -action_77 (163#) = happyShift action_224 -action_77 (164#) = happyShift action_225 -action_77 (166#) = happyShift action_226 -action_77 (35#) = happyGoto action_209 -action_77 x = happyTcHack x happyReduce_264 - -action_78 (96#) = happyShift action_24 -action_78 (98#) = happyShift action_25 -action_78 (104#) = happyShift action_26 -action_78 (109#) = happyShift action_27 -action_78 (110#) = happyShift action_28 -action_78 (111#) = happyShift action_29 -action_78 (114#) = happyShift action_30 -action_78 (119#) = happyShift action_31 -action_78 (124#) = happyShift action_32 -action_78 (125#) = happyShift action_33 -action_78 (126#) = happyShift action_34 -action_78 (127#) = happyShift action_35 -action_78 (128#) = happyShift action_36 -action_78 (129#) = happyShift action_37 -action_78 (131#) = happyShift action_38 -action_78 (134#) = happyShift action_39 -action_78 (137#) = happyShift action_40 -action_78 (140#) = happyShift action_41 -action_78 (145#) = happyShift action_42 -action_78 (156#) = happyShift action_43 -action_78 (157#) = happyShift action_44 -action_78 (161#) = happyShift action_45 -action_78 (162#) = happyShift action_46 -action_78 (167#) = happyShift action_47 -action_78 (170#) = happyShift action_6 -action_78 (171#) = happyShift action_48 -action_78 (172#) = happyShift action_49 -action_78 (173#) = happyShift action_50 -action_78 (174#) = happyShift action_51 -action_78 (8#) = happyGoto action_10 -action_78 (9#) = happyGoto action_11 -action_78 (10#) = happyGoto action_12 -action_78 (11#) = happyGoto action_13 -action_78 (12#) = happyGoto action_14 -action_78 (58#) = happyGoto action_15 -action_78 (59#) = happyGoto action_16 -action_78 (60#) = happyGoto action_17 -action_78 (61#) = happyGoto action_18 -action_78 (62#) = happyGoto action_19 -action_78 (63#) = happyGoto action_199 -action_78 (64#) = happyGoto action_21 -action_78 (65#) = happyGoto action_208 -action_78 (72#) = happyGoto action_22 -action_78 (77#) = happyGoto action_23 -action_78 x = happyTcHack x happyReduce_193 - -action_79 x = happyTcHack x happyReduce_140 - -action_80 (96#) = happyShift action_206 -action_80 (104#) = happyShift action_207 -action_80 x = happyTcHack x happyFail - -action_81 (96#) = happyShift action_106 -action_81 (98#) = happyShift action_107 -action_81 (104#) = happyShift action_108 -action_81 (106#) = happyShift action_176 -action_81 (110#) = happyShift action_109 -action_81 (111#) = happyShift action_110 -action_81 (114#) = happyShift action_111 -action_81 (121#) = happyShift action_112 -action_81 (170#) = happyShift action_6 -action_81 (171#) = happyShift action_48 -action_81 (172#) = happyShift action_49 -action_81 (174#) = happyShift action_51 -action_81 (8#) = happyGoto action_101 -action_81 (9#) = happyGoto action_102 -action_81 (10#) = happyGoto action_103 -action_81 (12#) = happyGoto action_202 -action_81 (53#) = happyGoto action_88 -action_81 (56#) = happyGoto action_89 -action_81 (57#) = happyGoto action_125 -action_81 (67#) = happyGoto action_171 -action_81 (68#) = happyGoto action_172 -action_81 (69#) = happyGoto action_203 -action_81 (82#) = happyGoto action_204 -action_81 (83#) = happyGoto action_205 -action_81 x = happyTcHack x happyReduce_137 - -action_82 (96#) = happyShift action_24 -action_82 (98#) = happyShift action_25 -action_82 (104#) = happyShift action_26 -action_82 (109#) = happyShift action_27 -action_82 (110#) = happyShift action_28 -action_82 (111#) = happyShift action_29 -action_82 (114#) = happyShift action_30 -action_82 (119#) = happyShift action_31 -action_82 (124#) = happyShift action_32 -action_82 (125#) = happyShift action_33 -action_82 (126#) = happyShift action_34 -action_82 (127#) = happyShift action_35 -action_82 (128#) = happyShift action_36 -action_82 (129#) = happyShift action_37 -action_82 (131#) = happyShift action_38 -action_82 (134#) = happyShift action_39 -action_82 (137#) = happyShift action_40 -action_82 (140#) = happyShift action_123 -action_82 (145#) = happyShift action_42 -action_82 (156#) = happyShift action_43 -action_82 (157#) = happyShift action_44 -action_82 (161#) = happyShift action_45 -action_82 (162#) = happyShift action_46 -action_82 (167#) = happyShift action_47 -action_82 (170#) = happyShift action_6 -action_82 (171#) = happyShift action_48 -action_82 (172#) = happyShift action_49 -action_82 (173#) = happyShift action_50 -action_82 (174#) = happyShift action_51 -action_82 (8#) = happyGoto action_10 -action_82 (9#) = happyGoto action_11 -action_82 (10#) = happyGoto action_12 -action_82 (11#) = happyGoto action_13 -action_82 (12#) = happyGoto action_14 -action_82 (58#) = happyGoto action_15 -action_82 (59#) = happyGoto action_16 -action_82 (60#) = happyGoto action_17 -action_82 (61#) = happyGoto action_18 -action_82 (62#) = happyGoto action_19 -action_82 (63#) = happyGoto action_121 -action_82 (64#) = happyGoto action_21 -action_82 (72#) = happyGoto action_22 -action_82 (77#) = happyGoto action_23 -action_82 x = happyTcHack x happyFail - -action_83 (174#) = happyShift action_51 -action_83 (12#) = happyGoto action_201 -action_83 x = happyTcHack x happyFail - -action_84 (96#) = happyShift action_24 -action_84 (98#) = happyShift action_25 -action_84 (104#) = happyShift action_26 -action_84 (109#) = happyShift action_27 -action_84 (110#) = happyShift action_28 -action_84 (111#) = happyShift action_29 -action_84 (114#) = happyShift action_30 -action_84 (119#) = happyShift action_31 -action_84 (124#) = happyShift action_32 -action_84 (125#) = happyShift action_33 -action_84 (126#) = happyShift action_34 -action_84 (127#) = happyShift action_35 -action_84 (128#) = happyShift action_36 -action_84 (129#) = happyShift action_37 -action_84 (131#) = happyShift action_38 -action_84 (134#) = happyShift action_39 -action_84 (137#) = happyShift action_40 -action_84 (140#) = happyShift action_41 -action_84 (145#) = happyShift action_42 -action_84 (156#) = happyShift action_43 -action_84 (157#) = happyShift action_44 -action_84 (161#) = happyShift action_45 -action_84 (162#) = happyShift action_46 -action_84 (167#) = happyShift action_47 -action_84 (170#) = happyShift action_6 -action_84 (171#) = happyShift action_48 -action_84 (172#) = happyShift action_49 -action_84 (173#) = happyShift action_50 -action_84 (174#) = happyShift action_51 -action_84 (8#) = happyGoto action_10 -action_84 (9#) = happyGoto action_11 -action_84 (10#) = happyGoto action_12 -action_84 (11#) = happyGoto action_13 -action_84 (12#) = happyGoto action_14 -action_84 (58#) = happyGoto action_15 -action_84 (59#) = happyGoto action_16 -action_84 (60#) = happyGoto action_17 -action_84 (61#) = happyGoto action_18 -action_84 (62#) = happyGoto action_19 -action_84 (63#) = happyGoto action_199 -action_84 (64#) = happyGoto action_21 -action_84 (65#) = happyGoto action_200 -action_84 (72#) = happyGoto action_22 -action_84 (77#) = happyGoto action_23 -action_84 x = happyTcHack x happyReduce_193 - -action_85 (96#) = happyShift action_24 -action_85 (98#) = happyShift action_25 -action_85 (104#) = happyShift action_26 -action_85 (109#) = happyShift action_27 -action_85 (110#) = happyShift action_28 -action_85 (111#) = happyShift action_29 -action_85 (114#) = happyShift action_30 -action_85 (119#) = happyShift action_31 -action_85 (124#) = happyShift action_32 -action_85 (125#) = happyShift action_33 -action_85 (126#) = happyShift action_34 -action_85 (127#) = happyShift action_35 -action_85 (128#) = happyShift action_36 -action_85 (129#) = happyShift action_37 -action_85 (131#) = happyShift action_38 -action_85 (134#) = happyShift action_39 -action_85 (137#) = happyShift action_40 -action_85 (140#) = happyShift action_41 -action_85 (145#) = happyShift action_42 -action_85 (156#) = happyShift action_43 -action_85 (157#) = happyShift action_44 -action_85 (161#) = happyShift action_45 -action_85 (162#) = happyShift action_46 -action_85 (167#) = happyShift action_47 -action_85 (170#) = happyShift action_6 -action_85 (171#) = happyShift action_48 -action_85 (172#) = happyShift action_49 -action_85 (173#) = happyShift action_50 -action_85 (174#) = happyShift action_51 -action_85 (8#) = happyGoto action_10 -action_85 (9#) = happyGoto action_11 -action_85 (10#) = happyGoto action_12 -action_85 (11#) = happyGoto action_13 -action_85 (12#) = happyGoto action_14 -action_85 (58#) = happyGoto action_15 -action_85 (59#) = happyGoto action_16 -action_85 (60#) = happyGoto action_17 -action_85 (61#) = happyGoto action_18 -action_85 (62#) = happyGoto action_19 -action_85 (63#) = happyGoto action_198 -action_85 (64#) = happyGoto action_21 -action_85 (72#) = happyGoto action_22 -action_85 (77#) = happyGoto action_23 -action_85 x = happyTcHack x happyFail - -action_86 (107#) = happyShift action_135 -action_86 x = happyTcHack x happyReduce_172 - -action_87 (103#) = happyShift action_156 -action_87 x = happyTcHack x happyReduce_128 - -action_88 (95#) = happyShift action_196 -action_88 (100#) = happyShift action_197 -action_88 x = happyTcHack x happyFail - -action_89 (94#) = happyShift action_195 -action_89 x = happyTcHack x happyReduce_138 - -action_90 (140#) = happyShift action_194 -action_90 x = happyTcHack x happyFail - -action_91 (174#) = happyShift action_51 -action_91 (12#) = happyGoto action_87 -action_91 (53#) = happyGoto action_88 -action_91 (56#) = happyGoto action_89 -action_91 (57#) = happyGoto action_193 -action_91 x = happyTcHack x happyReduce_137 - -action_92 (107#) = happyShift action_135 -action_92 (171#) = happyShift action_48 -action_92 (9#) = happyGoto action_192 -action_92 x = happyTcHack x happyFail - -action_93 (96#) = happyShift action_106 -action_93 (98#) = happyShift action_107 -action_93 (104#) = happyShift action_108 -action_93 (110#) = happyShift action_109 -action_93 (111#) = happyShift action_110 -action_93 (114#) = happyShift action_111 -action_93 (121#) = happyShift action_112 -action_93 (170#) = happyShift action_6 -action_93 (171#) = happyShift action_48 -action_93 (172#) = happyShift action_49 -action_93 (174#) = happyShift action_51 -action_93 (8#) = happyGoto action_101 -action_93 (9#) = happyGoto action_102 -action_93 (10#) = happyGoto action_103 -action_93 (12#) = happyGoto action_104 -action_93 (67#) = happyGoto action_188 -action_93 (74#) = happyGoto action_189 -action_93 (84#) = happyGoto action_190 -action_93 (85#) = happyGoto action_191 -action_93 x = happyTcHack x happyReduce_253 - -action_94 (150#) = happyShift action_187 -action_94 x = happyTcHack x happyFail - -action_95 x = happyTcHack x happyReduce_174 - -action_96 x = happyTcHack x happyReduce_234 - -action_97 (103#) = happyShift action_186 -action_97 x = happyTcHack x happyReduce_237 - -action_98 (101#) = happyShift action_185 -action_98 x = happyTcHack x happyFail - -action_99 (121#) = happyShift action_100 -action_99 (174#) = happyShift action_51 -action_99 (12#) = happyGoto action_96 -action_99 (75#) = happyGoto action_97 -action_99 (76#) = happyGoto action_184 -action_99 x = happyTcHack x happyReduce_236 - -action_100 x = happyTcHack x happyReduce_235 - -action_101 x = happyTcHack x happyReduce_206 - -action_102 x = happyTcHack x happyReduce_208 - -action_103 x = happyTcHack x happyReduce_207 - -action_104 (107#) = happyShift action_183 -action_104 x = happyTcHack x happyReduce_203 - -action_105 x = happyTcHack x happyReduce_171 - -action_106 (174#) = happyShift action_51 -action_106 (12#) = happyGoto action_179 -action_106 (53#) = happyGoto action_180 -action_106 (70#) = happyGoto action_181 -action_106 (73#) = happyGoto action_182 -action_106 x = happyTcHack x happyReduce_229 - -action_107 (96#) = happyShift action_106 -action_107 (98#) = happyShift action_107 -action_107 (104#) = happyShift action_108 -action_107 (106#) = happyShift action_176 -action_107 (110#) = happyShift action_109 -action_107 (111#) = happyShift action_110 -action_107 (114#) = happyShift action_111 -action_107 (121#) = happyShift action_112 -action_107 (170#) = happyShift action_6 -action_107 (171#) = happyShift action_48 -action_107 (172#) = happyShift action_49 -action_107 (174#) = happyShift action_51 -action_107 (8#) = happyGoto action_101 -action_107 (9#) = happyGoto action_102 -action_107 (10#) = happyGoto action_103 -action_107 (12#) = happyGoto action_170 -action_107 (67#) = happyGoto action_171 -action_107 (68#) = happyGoto action_172 -action_107 (69#) = happyGoto action_178 -action_107 x = happyTcHack x happyFail - -action_108 (171#) = happyShift action_48 -action_108 (9#) = happyGoto action_177 -action_108 x = happyTcHack x happyFail - -action_109 x = happyTcHack x happyReduce_198 - -action_110 (96#) = happyShift action_106 -action_110 (98#) = happyShift action_107 -action_110 (104#) = happyShift action_108 -action_110 (106#) = happyShift action_176 -action_110 (110#) = happyShift action_109 -action_110 (111#) = happyShift action_110 -action_110 (114#) = happyShift action_111 -action_110 (121#) = happyShift action_112 -action_110 (170#) = happyShift action_6 -action_110 (171#) = happyShift action_48 -action_110 (172#) = happyShift action_49 -action_110 (174#) = happyShift action_51 -action_110 (8#) = happyGoto action_101 -action_110 (9#) = happyGoto action_102 -action_110 (10#) = happyGoto action_103 -action_110 (12#) = happyGoto action_170 -action_110 (67#) = happyGoto action_171 -action_110 (68#) = happyGoto action_172 -action_110 (69#) = happyGoto action_173 -action_110 (79#) = happyGoto action_174 -action_110 (81#) = happyGoto action_175 -action_110 x = happyTcHack x happyReduce_246 - -action_111 (174#) = happyShift action_51 -action_111 (12#) = happyGoto action_169 -action_111 x = happyTcHack x happyFail - -action_112 x = happyTcHack x happyReduce_202 - -action_113 (100#) = happyShift action_168 -action_113 x = happyTcHack x happyReduce_241 - -action_114 (103#) = happyShift action_167 -action_114 x = happyTcHack x happyReduce_244 - -action_115 (112#) = happyShift action_166 -action_115 x = happyTcHack x happyFail - -action_116 (107#) = happyShift action_164 -action_116 (109#) = happyShift action_165 -action_116 x = happyTcHack x happyFail - -action_117 (105#) = happyShift action_163 -action_117 x = happyTcHack x happyFail - -action_118 (96#) = happyShift action_140 -action_118 (98#) = happyShift action_82 -action_118 (104#) = happyShift action_26 -action_118 (109#) = happyShift action_83 -action_118 (110#) = happyShift action_28 -action_118 (111#) = happyShift action_29 -action_118 (125#) = happyShift action_33 -action_118 (126#) = happyShift action_34 -action_118 (127#) = happyShift action_35 -action_118 (128#) = happyShift action_36 -action_118 (129#) = happyShift action_37 -action_118 (134#) = happyShift action_39 -action_118 (170#) = happyShift action_6 -action_118 (171#) = happyShift action_48 -action_118 (172#) = happyShift action_49 -action_118 (173#) = happyShift action_50 -action_118 (174#) = happyShift action_51 -action_118 (8#) = happyGoto action_10 -action_118 (9#) = happyGoto action_11 -action_118 (10#) = happyGoto action_12 -action_118 (11#) = happyGoto action_13 -action_118 (12#) = happyGoto action_79 -action_118 (58#) = happyGoto action_161 -action_118 (66#) = happyGoto action_162 -action_118 (72#) = happyGoto action_22 -action_118 x = happyTcHack x happyReduce_196 - -action_119 x = happyTcHack x happyReduce_148 - -action_120 (100#) = happyReduce_234 -action_120 (103#) = happyReduce_234 -action_120 (113#) = happyShift action_136 -action_120 x = happyTcHack x happyReduce_140 - -action_121 (99#) = happyShift action_160 -action_121 x = happyTcHack x happyFail - -action_122 (100#) = happyShift action_159 -action_122 x = happyTcHack x happyFail - -action_123 (96#) = happyShift action_24 -action_123 (98#) = happyShift action_82 -action_123 (104#) = happyShift action_26 -action_123 (109#) = happyShift action_27 -action_123 (110#) = happyShift action_28 -action_123 (111#) = happyShift action_29 -action_123 (125#) = happyShift action_33 -action_123 (126#) = happyShift action_34 -action_123 (127#) = happyShift action_35 -action_123 (128#) = happyShift action_36 -action_123 (129#) = happyShift action_37 -action_123 (134#) = happyShift action_39 -action_123 (170#) = happyShift action_6 -action_123 (171#) = happyShift action_48 -action_123 (172#) = happyShift action_49 -action_123 (173#) = happyShift action_50 -action_123 (174#) = happyShift action_51 -action_123 (8#) = happyGoto action_10 -action_123 (9#) = happyGoto action_11 -action_123 (10#) = happyGoto action_12 -action_123 (11#) = happyGoto action_13 -action_123 (12#) = happyGoto action_158 -action_123 (58#) = happyGoto action_15 -action_123 (59#) = happyGoto action_92 -action_123 (72#) = happyGoto action_22 -action_123 x = happyTcHack x happyFail - -action_124 (97#) = happyShift action_155 -action_124 (103#) = happyShift action_156 -action_124 (107#) = happyShift action_157 -action_124 x = happyTcHack x happyReduce_128 - -action_125 (97#) = happyShift action_154 -action_125 x = happyTcHack x happyFail - -action_126 (96#) = happyShift action_24 -action_126 (98#) = happyShift action_25 -action_126 (104#) = happyShift action_26 -action_126 (109#) = happyShift action_27 -action_126 (110#) = happyShift action_28 -action_126 (111#) = happyShift action_29 -action_126 (114#) = happyShift action_30 -action_126 (119#) = happyShift action_31 -action_126 (124#) = happyShift action_32 -action_126 (125#) = happyShift action_33 -action_126 (126#) = happyShift action_34 -action_126 (127#) = happyShift action_35 -action_126 (128#) = happyShift action_36 -action_126 (129#) = happyShift action_37 -action_126 (131#) = happyShift action_38 -action_126 (134#) = happyShift action_39 -action_126 (137#) = happyShift action_40 -action_126 (140#) = happyShift action_41 -action_126 (145#) = happyShift action_42 -action_126 (156#) = happyShift action_43 -action_126 (157#) = happyShift action_44 -action_126 (161#) = happyShift action_45 -action_126 (162#) = happyShift action_46 -action_126 (167#) = happyShift action_47 -action_126 (170#) = happyShift action_6 -action_126 (171#) = happyShift action_48 -action_126 (172#) = happyShift action_49 -action_126 (173#) = happyShift action_50 -action_126 (174#) = happyShift action_51 -action_126 (8#) = happyGoto action_10 -action_126 (9#) = happyGoto action_11 -action_126 (10#) = happyGoto action_12 -action_126 (11#) = happyGoto action_13 -action_126 (12#) = happyGoto action_14 -action_126 (58#) = happyGoto action_15 -action_126 (59#) = happyGoto action_16 -action_126 (60#) = happyGoto action_17 -action_126 (61#) = happyGoto action_18 -action_126 (62#) = happyGoto action_19 -action_126 (63#) = happyGoto action_153 -action_126 (64#) = happyGoto action_21 -action_126 (72#) = happyGoto action_22 -action_126 (77#) = happyGoto action_23 -action_126 x = happyTcHack x happyFail - -action_127 (96#) = happyShift action_24 -action_127 (98#) = happyShift action_82 -action_127 (104#) = happyShift action_26 -action_127 (109#) = happyShift action_27 -action_127 (110#) = happyShift action_28 -action_127 (111#) = happyShift action_29 -action_127 (114#) = happyShift action_30 -action_127 (124#) = happyShift action_32 -action_127 (125#) = happyShift action_33 -action_127 (126#) = happyShift action_34 -action_127 (127#) = happyShift action_35 -action_127 (128#) = happyShift action_36 -action_127 (129#) = happyShift action_37 -action_127 (131#) = happyShift action_38 -action_127 (134#) = happyShift action_39 -action_127 (156#) = happyShift action_43 -action_127 (157#) = happyShift action_44 -action_127 (161#) = happyShift action_45 -action_127 (162#) = happyShift action_46 -action_127 (167#) = happyShift action_47 -action_127 (170#) = happyShift action_6 -action_127 (171#) = happyShift action_48 -action_127 (172#) = happyShift action_49 -action_127 (173#) = happyShift action_50 -action_127 (174#) = happyShift action_51 -action_127 (8#) = happyGoto action_10 -action_127 (9#) = happyGoto action_11 -action_127 (10#) = happyGoto action_12 -action_127 (11#) = happyGoto action_13 -action_127 (12#) = happyGoto action_14 -action_127 (58#) = happyGoto action_15 -action_127 (59#) = happyGoto action_16 -action_127 (60#) = happyGoto action_150 -action_127 (61#) = happyGoto action_151 -action_127 (62#) = happyGoto action_152 -action_127 (64#) = happyGoto action_21 -action_127 (72#) = happyGoto action_22 -action_127 x = happyTcHack x happyFail - -action_128 (96#) = happyShift action_24 -action_128 (98#) = happyShift action_25 -action_128 (104#) = happyShift action_26 -action_128 (109#) = happyShift action_27 -action_128 (110#) = happyShift action_28 -action_128 (111#) = happyShift action_29 -action_128 (114#) = happyShift action_30 -action_128 (119#) = happyShift action_31 -action_128 (124#) = happyShift action_32 -action_128 (125#) = happyShift action_33 -action_128 (126#) = happyShift action_34 -action_128 (127#) = happyShift action_35 -action_128 (128#) = happyShift action_36 -action_128 (129#) = happyShift action_37 -action_128 (131#) = happyShift action_38 -action_128 (134#) = happyShift action_39 -action_128 (137#) = happyShift action_40 -action_128 (140#) = happyShift action_41 -action_128 (145#) = happyShift action_42 -action_128 (156#) = happyShift action_43 -action_128 (157#) = happyShift action_44 -action_128 (161#) = happyShift action_45 -action_128 (162#) = happyShift action_46 -action_128 (167#) = happyShift action_47 -action_128 (170#) = happyShift action_6 -action_128 (171#) = happyShift action_48 -action_128 (172#) = happyShift action_49 -action_128 (173#) = happyShift action_50 -action_128 (174#) = happyShift action_51 -action_128 (8#) = happyGoto action_10 -action_128 (9#) = happyGoto action_11 -action_128 (10#) = happyGoto action_12 -action_128 (11#) = happyGoto action_13 -action_128 (12#) = happyGoto action_14 -action_128 (58#) = happyGoto action_15 -action_128 (59#) = happyGoto action_16 -action_128 (60#) = happyGoto action_17 -action_128 (61#) = happyGoto action_18 -action_128 (62#) = happyGoto action_19 -action_128 (63#) = happyGoto action_149 -action_128 (64#) = happyGoto action_21 -action_128 (72#) = happyGoto action_22 -action_128 (77#) = happyGoto action_23 -action_128 x = happyTcHack x happyFail - -action_129 (96#) = happyShift action_24 -action_129 (98#) = happyShift action_82 -action_129 (104#) = happyShift action_26 -action_129 (109#) = happyShift action_27 -action_129 (110#) = happyShift action_28 -action_129 (111#) = happyShift action_29 -action_129 (114#) = happyShift action_30 -action_129 (124#) = happyShift action_32 -action_129 (125#) = happyShift action_33 -action_129 (126#) = happyShift action_34 -action_129 (127#) = happyShift action_35 -action_129 (128#) = happyShift action_36 -action_129 (129#) = happyShift action_37 -action_129 (131#) = happyShift action_38 -action_129 (134#) = happyShift action_39 -action_129 (156#) = happyShift action_43 -action_129 (157#) = happyShift action_44 -action_129 (161#) = happyShift action_45 -action_129 (162#) = happyShift action_46 -action_129 (167#) = happyShift action_47 -action_129 (170#) = happyShift action_6 -action_129 (171#) = happyShift action_48 -action_129 (172#) = happyShift action_49 -action_129 (173#) = happyShift action_50 -action_129 (174#) = happyShift action_51 -action_129 (8#) = happyGoto action_10 -action_129 (9#) = happyGoto action_11 -action_129 (10#) = happyGoto action_12 -action_129 (11#) = happyGoto action_13 -action_129 (12#) = happyGoto action_14 -action_129 (58#) = happyGoto action_15 -action_129 (59#) = happyGoto action_16 -action_129 (60#) = happyGoto action_148 -action_129 (72#) = happyGoto action_22 -action_129 x = happyTcHack x happyFail - -action_130 (96#) = happyShift action_24 -action_130 (98#) = happyShift action_82 -action_130 (104#) = happyShift action_26 -action_130 (109#) = happyShift action_27 -action_130 (110#) = happyShift action_28 -action_130 (111#) = happyShift action_29 -action_130 (114#) = happyShift action_30 -action_130 (124#) = happyShift action_32 -action_130 (125#) = happyShift action_33 -action_130 (126#) = happyShift action_34 -action_130 (127#) = happyShift action_35 -action_130 (128#) = happyShift action_36 -action_130 (129#) = happyShift action_37 -action_130 (131#) = happyShift action_38 -action_130 (134#) = happyShift action_39 -action_130 (156#) = happyShift action_43 -action_130 (157#) = happyShift action_44 -action_130 (161#) = happyShift action_45 -action_130 (162#) = happyShift action_46 -action_130 (167#) = happyShift action_47 -action_130 (170#) = happyShift action_6 -action_130 (171#) = happyShift action_48 -action_130 (172#) = happyShift action_49 -action_130 (173#) = happyShift action_50 -action_130 (174#) = happyShift action_51 -action_130 (8#) = happyGoto action_10 -action_130 (9#) = happyGoto action_11 -action_130 (10#) = happyGoto action_12 -action_130 (11#) = happyGoto action_13 -action_130 (12#) = happyGoto action_14 -action_130 (58#) = happyGoto action_15 -action_130 (59#) = happyGoto action_16 -action_130 (60#) = happyGoto action_147 -action_130 (72#) = happyGoto action_22 -action_130 x = happyTcHack x happyFail - -action_131 (96#) = happyShift action_24 -action_131 (98#) = happyShift action_82 -action_131 (104#) = happyShift action_26 -action_131 (109#) = happyShift action_27 -action_131 (110#) = happyShift action_28 -action_131 (111#) = happyShift action_29 -action_131 (114#) = happyShift action_30 -action_131 (124#) = happyShift action_32 -action_131 (125#) = happyShift action_33 -action_131 (126#) = happyShift action_34 -action_131 (127#) = happyShift action_35 -action_131 (128#) = happyShift action_36 -action_131 (129#) = happyShift action_37 -action_131 (131#) = happyShift action_38 -action_131 (134#) = happyShift action_39 -action_131 (156#) = happyShift action_43 -action_131 (157#) = happyShift action_44 -action_131 (161#) = happyShift action_45 -action_131 (162#) = happyShift action_46 -action_131 (167#) = happyShift action_47 -action_131 (170#) = happyShift action_6 -action_131 (171#) = happyShift action_48 -action_131 (172#) = happyShift action_49 -action_131 (173#) = happyShift action_50 -action_131 (174#) = happyShift action_51 -action_131 (8#) = happyGoto action_10 -action_131 (9#) = happyGoto action_11 -action_131 (10#) = happyGoto action_12 -action_131 (11#) = happyGoto action_13 -action_131 (12#) = happyGoto action_14 -action_131 (58#) = happyGoto action_15 -action_131 (59#) = happyGoto action_16 -action_131 (60#) = happyGoto action_146 -action_131 (72#) = happyGoto action_22 -action_131 x = happyTcHack x happyFail - -action_132 (96#) = happyShift action_24 -action_132 (98#) = happyShift action_25 -action_132 (104#) = happyShift action_26 -action_132 (109#) = happyShift action_27 -action_132 (110#) = happyShift action_28 -action_132 (111#) = happyShift action_29 -action_132 (114#) = happyShift action_30 -action_132 (119#) = happyShift action_31 -action_132 (124#) = happyShift action_32 -action_132 (125#) = happyShift action_33 -action_132 (126#) = happyShift action_34 -action_132 (127#) = happyShift action_35 -action_132 (128#) = happyShift action_36 -action_132 (129#) = happyShift action_37 -action_132 (131#) = happyShift action_38 -action_132 (134#) = happyShift action_39 -action_132 (137#) = happyShift action_40 -action_132 (140#) = happyShift action_41 -action_132 (145#) = happyShift action_42 -action_132 (156#) = happyShift action_43 -action_132 (157#) = happyShift action_44 -action_132 (161#) = happyShift action_45 -action_132 (162#) = happyShift action_46 -action_132 (167#) = happyShift action_47 -action_132 (170#) = happyShift action_6 -action_132 (171#) = happyShift action_48 -action_132 (172#) = happyShift action_49 -action_132 (173#) = happyShift action_50 -action_132 (174#) = happyShift action_51 -action_132 (8#) = happyGoto action_10 -action_132 (9#) = happyGoto action_11 -action_132 (10#) = happyGoto action_12 -action_132 (11#) = happyGoto action_13 -action_132 (12#) = happyGoto action_14 -action_132 (58#) = happyGoto action_15 -action_132 (59#) = happyGoto action_16 -action_132 (60#) = happyGoto action_17 -action_132 (61#) = happyGoto action_18 -action_132 (62#) = happyGoto action_19 -action_132 (63#) = happyGoto action_145 -action_132 (64#) = happyGoto action_21 -action_132 (72#) = happyGoto action_22 -action_132 (77#) = happyGoto action_23 -action_132 x = happyTcHack x happyFail - -action_133 (96#) = happyShift action_144 -action_133 x = happyTcHack x happyFail - -action_134 (107#) = happyShift action_135 -action_134 x = happyTcHack x happyReduce_162 - -action_135 (122#) = happyShift action_143 -action_135 (174#) = happyShift action_51 -action_135 (12#) = happyGoto action_141 -action_135 (71#) = happyGoto action_142 -action_135 x = happyTcHack x happyFail - -action_136 (96#) = happyShift action_140 -action_136 (98#) = happyShift action_82 -action_136 (104#) = happyShift action_26 -action_136 (109#) = happyShift action_83 -action_136 (110#) = happyShift action_28 -action_136 (111#) = happyShift action_29 -action_136 (125#) = happyShift action_33 -action_136 (126#) = happyShift action_34 -action_136 (127#) = happyShift action_35 -action_136 (128#) = happyShift action_36 -action_136 (129#) = happyShift action_37 -action_136 (134#) = happyShift action_39 -action_136 (170#) = happyShift action_6 -action_136 (171#) = happyShift action_48 -action_136 (172#) = happyShift action_49 -action_136 (173#) = happyShift action_50 -action_136 (174#) = happyShift action_51 -action_136 (8#) = happyGoto action_10 -action_136 (9#) = happyGoto action_11 -action_136 (10#) = happyGoto action_12 -action_136 (11#) = happyGoto action_13 -action_136 (12#) = happyGoto action_79 -action_136 (58#) = happyGoto action_139 -action_136 (72#) = happyGoto action_22 -action_136 x = happyTcHack x happyFail - -action_137 (95#) = happyShift action_138 -action_137 x = happyTcHack x happyFail - -action_138 (1#) = happyReduce_65 -action_138 (102#) = happyReduce_65 -action_138 (151#) = happyReduce_51 -action_138 (160#) = happyShift action_347 -action_138 (165#) = happyShift action_348 -action_138 (174#) = happyShift action_51 -action_138 (12#) = happyGoto action_241 -action_138 (22#) = happyGoto action_343 -action_138 (26#) = happyGoto action_344 -action_138 (32#) = happyGoto action_345 -action_138 (33#) = happyGoto action_346 -action_138 x = happyTcHack x happyReduce_65 - -action_139 x = happyTcHack x happyReduce_170 - -action_140 (174#) = happyShift action_51 -action_140 (12#) = happyGoto action_342 -action_140 (53#) = happyGoto action_88 -action_140 (56#) = happyGoto action_89 -action_140 (57#) = happyGoto action_125 -action_140 x = happyTcHack x happyReduce_137 - -action_141 x = happyTcHack x happyReduce_222 - -action_142 x = happyTcHack x happyReduce_158 - -action_143 (170#) = happyShift action_6 -action_143 (8#) = happyGoto action_341 -action_143 x = happyTcHack x happyFail - -action_144 (174#) = happyShift action_51 -action_144 (12#) = happyGoto action_87 -action_144 (53#) = happyGoto action_88 -action_144 (56#) = happyGoto action_89 -action_144 (57#) = happyGoto action_340 -action_144 x = happyTcHack x happyReduce_137 - -action_145 x = happyTcHack x happyReduce_185 - -action_146 (96#) = happyShift action_24 -action_146 (98#) = happyShift action_82 -action_146 (104#) = happyShift action_26 -action_146 (109#) = happyShift action_27 -action_146 (110#) = happyShift action_28 -action_146 (111#) = happyShift action_29 -action_146 (125#) = happyShift action_33 -action_146 (126#) = happyShift action_34 -action_146 (127#) = happyShift action_35 -action_146 (128#) = happyShift action_36 -action_146 (129#) = happyShift action_37 -action_146 (134#) = happyShift action_39 -action_146 (170#) = happyShift action_6 -action_146 (171#) = happyShift action_48 -action_146 (172#) = happyShift action_49 -action_146 (173#) = happyShift action_50 -action_146 (174#) = happyShift action_51 -action_146 (8#) = happyGoto action_10 -action_146 (9#) = happyGoto action_11 -action_146 (10#) = happyGoto action_12 -action_146 (11#) = happyGoto action_13 -action_146 (12#) = happyGoto action_79 -action_146 (58#) = happyGoto action_15 -action_146 (59#) = happyGoto action_134 -action_146 (72#) = happyGoto action_22 -action_146 x = happyTcHack x happyReduce_176 - -action_147 (96#) = happyShift action_24 -action_147 (98#) = happyShift action_82 -action_147 (104#) = happyShift action_26 -action_147 (109#) = happyShift action_27 -action_147 (110#) = happyShift action_28 -action_147 (111#) = happyShift action_29 -action_147 (125#) = happyShift action_33 -action_147 (126#) = happyShift action_34 -action_147 (127#) = happyShift action_35 -action_147 (128#) = happyShift action_36 -action_147 (129#) = happyShift action_37 -action_147 (134#) = happyShift action_39 -action_147 (170#) = happyShift action_6 -action_147 (171#) = happyShift action_48 -action_147 (172#) = happyShift action_49 -action_147 (173#) = happyShift action_50 -action_147 (174#) = happyShift action_51 -action_147 (8#) = happyGoto action_10 -action_147 (9#) = happyGoto action_11 -action_147 (10#) = happyGoto action_12 -action_147 (11#) = happyGoto action_13 -action_147 (12#) = happyGoto action_79 -action_147 (58#) = happyGoto action_15 -action_147 (59#) = happyGoto action_134 -action_147 (72#) = happyGoto action_22 -action_147 x = happyTcHack x happyReduce_175 - -action_148 (96#) = happyShift action_24 -action_148 (98#) = happyShift action_82 -action_148 (104#) = happyShift action_26 -action_148 (109#) = happyShift action_27 -action_148 (110#) = happyShift action_28 -action_148 (111#) = happyShift action_29 -action_148 (125#) = happyShift action_33 -action_148 (126#) = happyShift action_34 -action_148 (127#) = happyShift action_35 -action_148 (128#) = happyShift action_36 -action_148 (129#) = happyShift action_37 -action_148 (134#) = happyShift action_39 -action_148 (170#) = happyShift action_6 -action_148 (171#) = happyShift action_48 -action_148 (172#) = happyShift action_49 -action_148 (173#) = happyShift action_50 -action_148 (174#) = happyShift action_51 -action_148 (8#) = happyGoto action_10 -action_148 (9#) = happyGoto action_11 -action_148 (10#) = happyGoto action_12 -action_148 (11#) = happyGoto action_13 -action_148 (12#) = happyGoto action_79 -action_148 (58#) = happyGoto action_15 -action_148 (59#) = happyGoto action_134 -action_148 (72#) = happyGoto action_22 -action_148 x = happyTcHack x happyReduce_177 - -action_149 x = happyTcHack x happyReduce_181 - -action_150 (96#) = happyShift action_24 -action_150 (98#) = happyShift action_82 -action_150 (104#) = happyShift action_26 -action_150 (109#) = happyShift action_27 -action_150 (110#) = happyShift action_28 -action_150 (111#) = happyShift action_29 -action_150 (125#) = happyShift action_33 -action_150 (126#) = happyShift action_34 -action_150 (127#) = happyShift action_35 -action_150 (128#) = happyShift action_36 -action_150 (129#) = happyShift action_37 -action_150 (134#) = happyShift action_39 -action_150 (170#) = happyShift action_6 -action_150 (171#) = happyShift action_48 -action_150 (172#) = happyShift action_49 -action_150 (173#) = happyShift action_50 -action_150 (174#) = happyShift action_51 -action_150 (8#) = happyGoto action_10 -action_150 (9#) = happyGoto action_11 -action_150 (10#) = happyGoto action_12 -action_150 (11#) = happyGoto action_13 -action_150 (12#) = happyGoto action_79 -action_150 (58#) = happyGoto action_15 -action_150 (59#) = happyGoto action_134 -action_150 (72#) = happyGoto action_22 -action_150 x = happyTcHack x happyReduce_178 - -action_151 (102#) = happyShift action_129 -action_151 (115#) = happyShift action_130 -action_151 (116#) = happyShift action_131 -action_151 x = happyTcHack x happyReduce_192 - -action_152 x = happyTcHack x happyReduce_179 - -action_153 x = happyTcHack x happyReduce_184 - -action_154 x = happyTcHack x happyReduce_152 - -action_155 x = happyTcHack x happyReduce_141 - -action_156 (174#) = happyShift action_51 -action_156 (12#) = happyGoto action_87 -action_156 (53#) = happyGoto action_339 -action_156 x = happyTcHack x happyFail - -action_157 (174#) = happyShift action_51 -action_157 (12#) = happyGoto action_338 -action_157 x = happyTcHack x happyFail - -action_158 (99#) = happyShift action_337 -action_158 x = happyTcHack x happyReduce_140 - -action_159 (96#) = happyShift action_24 -action_159 (98#) = happyShift action_25 -action_159 (104#) = happyShift action_26 -action_159 (109#) = happyShift action_27 -action_159 (110#) = happyShift action_28 -action_159 (111#) = happyShift action_29 -action_159 (114#) = happyShift action_30 -action_159 (119#) = happyShift action_31 -action_159 (124#) = happyShift action_32 -action_159 (125#) = happyShift action_33 -action_159 (126#) = happyShift action_34 -action_159 (127#) = happyShift action_35 -action_159 (128#) = happyShift action_36 -action_159 (129#) = happyShift action_37 -action_159 (131#) = happyShift action_38 -action_159 (134#) = happyShift action_39 -action_159 (137#) = happyShift action_40 -action_159 (140#) = happyShift action_41 -action_159 (145#) = happyShift action_42 -action_159 (156#) = happyShift action_43 -action_159 (157#) = happyShift action_44 -action_159 (161#) = happyShift action_45 -action_159 (162#) = happyShift action_46 -action_159 (167#) = happyShift action_47 -action_159 (170#) = happyShift action_6 -action_159 (171#) = happyShift action_48 -action_159 (172#) = happyShift action_49 -action_159 (173#) = happyShift action_50 -action_159 (174#) = happyShift action_51 -action_159 (8#) = happyGoto action_10 -action_159 (9#) = happyGoto action_11 -action_159 (10#) = happyGoto action_12 -action_159 (11#) = happyGoto action_13 -action_159 (12#) = happyGoto action_14 -action_159 (58#) = happyGoto action_15 -action_159 (59#) = happyGoto action_16 -action_159 (60#) = happyGoto action_17 -action_159 (61#) = happyGoto action_18 -action_159 (62#) = happyGoto action_19 -action_159 (63#) = happyGoto action_336 -action_159 (64#) = happyGoto action_21 -action_159 (72#) = happyGoto action_22 -action_159 (77#) = happyGoto action_23 -action_159 x = happyTcHack x happyFail - -action_160 x = happyTcHack x happyReduce_156 - -action_161 (96#) = happyShift action_140 -action_161 (98#) = happyShift action_82 -action_161 (104#) = happyShift action_26 -action_161 (109#) = happyShift action_83 -action_161 (110#) = happyShift action_28 -action_161 (111#) = happyShift action_29 -action_161 (125#) = happyShift action_33 -action_161 (126#) = happyShift action_34 -action_161 (127#) = happyShift action_35 -action_161 (128#) = happyShift action_36 -action_161 (129#) = happyShift action_37 -action_161 (134#) = happyShift action_39 -action_161 (170#) = happyShift action_6 -action_161 (171#) = happyShift action_48 -action_161 (172#) = happyShift action_49 -action_161 (173#) = happyShift action_50 -action_161 (174#) = happyShift action_51 -action_161 (8#) = happyGoto action_10 -action_161 (9#) = happyGoto action_11 -action_161 (10#) = happyGoto action_12 -action_161 (11#) = happyGoto action_13 -action_161 (12#) = happyGoto action_79 -action_161 (58#) = happyGoto action_161 -action_161 (66#) = happyGoto action_335 -action_161 (72#) = happyGoto action_22 -action_161 x = happyTcHack x happyReduce_196 - -action_162 (105#) = happyShift action_334 -action_162 x = happyTcHack x happyFail - -action_163 x = happyTcHack x happyReduce_151 - -action_164 (174#) = happyShift action_51 -action_164 (12#) = happyGoto action_333 -action_164 x = happyTcHack x happyFail - -action_165 x = happyTcHack x happyReduce_142 - -action_166 x = happyTcHack x happyReduce_153 - -action_167 (96#) = happyShift action_24 -action_167 (98#) = happyShift action_25 -action_167 (104#) = happyShift action_26 -action_167 (109#) = happyShift action_27 -action_167 (110#) = happyShift action_28 -action_167 (111#) = happyShift action_29 -action_167 (114#) = happyShift action_30 -action_167 (119#) = happyShift action_31 -action_167 (124#) = happyShift action_32 -action_167 (125#) = happyShift action_33 -action_167 (126#) = happyShift action_34 -action_167 (127#) = happyShift action_35 -action_167 (128#) = happyShift action_36 -action_167 (129#) = happyShift action_37 -action_167 (131#) = happyShift action_38 -action_167 (134#) = happyShift action_39 -action_167 (137#) = happyShift action_40 -action_167 (140#) = happyShift action_41 -action_167 (145#) = happyShift action_42 -action_167 (156#) = happyShift action_43 -action_167 (157#) = happyShift action_44 -action_167 (161#) = happyShift action_45 -action_167 (162#) = happyShift action_46 -action_167 (167#) = happyShift action_47 -action_167 (170#) = happyShift action_6 -action_167 (171#) = happyShift action_48 -action_167 (172#) = happyShift action_49 -action_167 (173#) = happyShift action_50 -action_167 (174#) = happyShift action_51 -action_167 (8#) = happyGoto action_10 -action_167 (9#) = happyGoto action_11 -action_167 (10#) = happyGoto action_12 -action_167 (11#) = happyGoto action_13 -action_167 (12#) = happyGoto action_14 -action_167 (58#) = happyGoto action_15 -action_167 (59#) = happyGoto action_16 -action_167 (60#) = happyGoto action_17 -action_167 (61#) = happyGoto action_18 -action_167 (62#) = happyGoto action_19 -action_167 (63#) = happyGoto action_331 -action_167 (64#) = happyGoto action_21 -action_167 (72#) = happyGoto action_22 -action_167 (77#) = happyGoto action_23 -action_167 (78#) = happyGoto action_114 -action_167 (80#) = happyGoto action_332 -action_167 x = happyTcHack x happyReduce_243 - -action_168 (96#) = happyShift action_24 -action_168 (98#) = happyShift action_25 -action_168 (104#) = happyShift action_26 -action_168 (109#) = happyShift action_27 -action_168 (110#) = happyShift action_28 -action_168 (111#) = happyShift action_29 -action_168 (114#) = happyShift action_30 -action_168 (119#) = happyShift action_31 -action_168 (124#) = happyShift action_32 -action_168 (125#) = happyShift action_33 -action_168 (126#) = happyShift action_34 -action_168 (127#) = happyShift action_35 -action_168 (128#) = happyShift action_36 -action_168 (129#) = happyShift action_37 -action_168 (131#) = happyShift action_38 -action_168 (134#) = happyShift action_39 -action_168 (137#) = happyShift action_40 -action_168 (140#) = happyShift action_41 -action_168 (145#) = happyShift action_42 -action_168 (156#) = happyShift action_43 -action_168 (157#) = happyShift action_44 -action_168 (161#) = happyShift action_45 -action_168 (162#) = happyShift action_46 -action_168 (167#) = happyShift action_47 -action_168 (170#) = happyShift action_6 -action_168 (171#) = happyShift action_48 -action_168 (172#) = happyShift action_49 -action_168 (173#) = happyShift action_50 -action_168 (174#) = happyShift action_51 -action_168 (8#) = happyGoto action_10 -action_168 (9#) = happyGoto action_11 -action_168 (10#) = happyGoto action_12 -action_168 (11#) = happyGoto action_13 -action_168 (12#) = happyGoto action_14 -action_168 (58#) = happyGoto action_15 -action_168 (59#) = happyGoto action_16 -action_168 (60#) = happyGoto action_17 -action_168 (61#) = happyGoto action_18 -action_168 (62#) = happyGoto action_19 -action_168 (63#) = happyGoto action_330 -action_168 (64#) = happyGoto action_21 -action_168 (72#) = happyGoto action_22 -action_168 (77#) = happyGoto action_23 -action_168 x = happyTcHack x happyFail - -action_169 (107#) = happyShift action_329 -action_169 x = happyTcHack x happyReduce_200 - -action_170 (96#) = happyShift action_106 -action_170 (98#) = happyShift action_107 -action_170 (104#) = happyShift action_108 -action_170 (107#) = happyShift action_300 -action_170 (110#) = happyShift action_109 -action_170 (111#) = happyShift action_110 -action_170 (113#) = happyShift action_301 -action_170 (114#) = happyShift action_111 -action_170 (121#) = happyShift action_112 -action_170 (170#) = happyShift action_6 -action_170 (171#) = happyShift action_48 -action_170 (172#) = happyShift action_49 -action_170 (174#) = happyShift action_51 -action_170 (8#) = happyGoto action_101 -action_170 (9#) = happyGoto action_102 -action_170 (10#) = happyGoto action_103 -action_170 (12#) = happyGoto action_104 -action_170 (67#) = happyGoto action_188 -action_170 (74#) = happyGoto action_299 -action_170 x = happyTcHack x happyReduce_203 - -action_171 (116#) = happyShift action_328 -action_171 x = happyTcHack x happyReduce_217 - -action_172 x = happyTcHack x happyReduce_220 - -action_173 (108#) = happyShift action_296 -action_173 (117#) = happyShift action_297 -action_173 x = happyTcHack x happyReduce_242 - -action_174 (103#) = happyShift action_327 -action_174 x = happyTcHack x happyReduce_247 - -action_175 (112#) = happyShift action_326 -action_175 x = happyTcHack x happyFail - -action_176 (96#) = happyShift action_106 -action_176 (98#) = happyShift action_107 -action_176 (104#) = happyShift action_108 -action_176 (110#) = happyShift action_109 -action_176 (111#) = happyShift action_110 -action_176 (114#) = happyShift action_111 -action_176 (121#) = happyShift action_112 -action_176 (170#) = happyShift action_6 -action_176 (171#) = happyShift action_48 -action_176 (172#) = happyShift action_49 -action_176 (174#) = happyShift action_51 -action_176 (8#) = happyGoto action_101 -action_176 (9#) = happyGoto action_102 -action_176 (10#) = happyGoto action_103 -action_176 (12#) = happyGoto action_104 -action_176 (67#) = happyGoto action_325 -action_176 x = happyTcHack x happyFail - -action_177 (105#) = happyShift action_324 -action_177 x = happyTcHack x happyFail - -action_178 (99#) = happyShift action_323 -action_178 (108#) = happyShift action_296 -action_178 (117#) = happyShift action_297 -action_178 x = happyTcHack x happyFail - -action_179 (97#) = happyShift action_322 -action_179 (103#) = happyShift action_156 -action_179 x = happyTcHack x happyReduce_128 - -action_180 (95#) = happyShift action_321 -action_180 x = happyTcHack x happyFail - -action_181 (94#) = happyShift action_320 -action_181 x = happyTcHack x happyReduce_230 - -action_182 (97#) = happyShift action_319 -action_182 x = happyTcHack x happyFail - -action_183 (174#) = happyShift action_51 -action_183 (12#) = happyGoto action_318 -action_183 x = happyTcHack x happyFail - -action_184 (120#) = happyShift action_317 -action_184 x = happyTcHack x happyFail - -action_185 (96#) = happyShift action_24 -action_185 (98#) = happyShift action_25 -action_185 (104#) = happyShift action_26 -action_185 (109#) = happyShift action_27 -action_185 (110#) = happyShift action_28 -action_185 (111#) = happyShift action_29 -action_185 (114#) = happyShift action_30 -action_185 (119#) = happyShift action_31 -action_185 (124#) = happyShift action_32 -action_185 (125#) = happyShift action_33 -action_185 (126#) = happyShift action_34 -action_185 (127#) = happyShift action_35 -action_185 (128#) = happyShift action_36 -action_185 (129#) = happyShift action_37 -action_185 (131#) = happyShift action_38 -action_185 (134#) = happyShift action_39 -action_185 (137#) = happyShift action_40 -action_185 (140#) = happyShift action_41 -action_185 (145#) = happyShift action_42 -action_185 (156#) = happyShift action_43 -action_185 (157#) = happyShift action_44 -action_185 (161#) = happyShift action_45 -action_185 (162#) = happyShift action_46 -action_185 (167#) = happyShift action_47 -action_185 (170#) = happyShift action_6 -action_185 (171#) = happyShift action_48 -action_185 (172#) = happyShift action_49 -action_185 (173#) = happyShift action_50 -action_185 (174#) = happyShift action_51 -action_185 (8#) = happyGoto action_10 -action_185 (9#) = happyGoto action_11 -action_185 (10#) = happyGoto action_12 -action_185 (11#) = happyGoto action_13 -action_185 (12#) = happyGoto action_14 -action_185 (58#) = happyGoto action_15 -action_185 (59#) = happyGoto action_16 -action_185 (60#) = happyGoto action_17 -action_185 (61#) = happyGoto action_18 -action_185 (62#) = happyGoto action_19 -action_185 (63#) = happyGoto action_316 -action_185 (64#) = happyGoto action_21 -action_185 (72#) = happyGoto action_22 -action_185 (77#) = happyGoto action_23 -action_185 x = happyTcHack x happyFail - -action_186 (121#) = happyShift action_100 -action_186 (174#) = happyShift action_51 -action_186 (12#) = happyGoto action_96 -action_186 (75#) = happyGoto action_97 -action_186 (76#) = happyGoto action_315 -action_186 x = happyTcHack x happyReduce_236 - -action_187 (96#) = happyShift action_314 -action_187 x = happyTcHack x happyFail - -action_188 (96#) = happyShift action_106 -action_188 (98#) = happyShift action_107 -action_188 (104#) = happyShift action_108 -action_188 (110#) = happyShift action_109 -action_188 (111#) = happyShift action_110 -action_188 (114#) = happyShift action_111 -action_188 (121#) = happyShift action_112 -action_188 (170#) = happyShift action_6 -action_188 (171#) = happyShift action_48 -action_188 (172#) = happyShift action_49 -action_188 (174#) = happyShift action_51 -action_188 (8#) = happyGoto action_101 -action_188 (9#) = happyGoto action_102 -action_188 (10#) = happyGoto action_103 -action_188 (12#) = happyGoto action_104 -action_188 (67#) = happyGoto action_188 -action_188 (74#) = happyGoto action_313 -action_188 x = happyTcHack x happyReduce_232 - -action_189 (101#) = happyShift action_312 -action_189 x = happyTcHack x happyFail - -action_190 (94#) = happyShift action_311 -action_190 x = happyTcHack x happyReduce_254 - -action_191 (97#) = happyShift action_310 -action_191 x = happyTcHack x happyFail - -action_192 x = happyTcHack x happyReduce_190 - -action_193 (97#) = happyShift action_309 -action_193 x = happyTcHack x happyFail - -action_194 (96#) = happyShift action_24 -action_194 (98#) = happyShift action_25 -action_194 (104#) = happyShift action_26 -action_194 (109#) = happyShift action_27 -action_194 (110#) = happyShift action_28 -action_194 (111#) = happyShift action_29 -action_194 (114#) = happyShift action_30 -action_194 (119#) = happyShift action_31 -action_194 (124#) = happyShift action_32 -action_194 (125#) = happyShift action_33 -action_194 (126#) = happyShift action_34 -action_194 (127#) = happyShift action_35 -action_194 (128#) = happyShift action_36 -action_194 (129#) = happyShift action_37 -action_194 (131#) = happyShift action_38 -action_194 (134#) = happyShift action_39 -action_194 (137#) = happyShift action_40 -action_194 (140#) = happyShift action_41 -action_194 (145#) = happyShift action_42 -action_194 (156#) = happyShift action_43 -action_194 (157#) = happyShift action_44 -action_194 (161#) = happyShift action_45 -action_194 (162#) = happyShift action_46 -action_194 (167#) = happyShift action_47 -action_194 (170#) = happyShift action_6 -action_194 (171#) = happyShift action_48 -action_194 (172#) = happyShift action_49 -action_194 (173#) = happyShift action_50 -action_194 (174#) = happyShift action_51 -action_194 (8#) = happyGoto action_10 -action_194 (9#) = happyGoto action_11 -action_194 (10#) = happyGoto action_12 -action_194 (11#) = happyGoto action_13 -action_194 (12#) = happyGoto action_14 -action_194 (58#) = happyGoto action_15 -action_194 (59#) = happyGoto action_16 -action_194 (60#) = happyGoto action_17 -action_194 (61#) = happyGoto action_18 -action_194 (62#) = happyGoto action_19 -action_194 (63#) = happyGoto action_308 -action_194 (64#) = happyGoto action_21 -action_194 (72#) = happyGoto action_22 -action_194 (77#) = happyGoto action_23 -action_194 x = happyTcHack x happyFail - -action_195 (174#) = happyShift action_51 -action_195 (12#) = happyGoto action_87 -action_195 (53#) = happyGoto action_88 -action_195 (56#) = happyGoto action_89 -action_195 (57#) = happyGoto action_307 -action_195 x = happyTcHack x happyReduce_137 - -action_196 (96#) = happyShift action_24 -action_196 (98#) = happyShift action_25 -action_196 (104#) = happyShift action_26 -action_196 (109#) = happyShift action_27 -action_196 (110#) = happyShift action_28 -action_196 (111#) = happyShift action_29 -action_196 (114#) = happyShift action_30 -action_196 (119#) = happyShift action_31 -action_196 (124#) = happyShift action_32 -action_196 (125#) = happyShift action_33 -action_196 (126#) = happyShift action_34 -action_196 (127#) = happyShift action_35 -action_196 (128#) = happyShift action_36 -action_196 (129#) = happyShift action_37 -action_196 (131#) = happyShift action_38 -action_196 (134#) = happyShift action_39 -action_196 (137#) = happyShift action_40 -action_196 (140#) = happyShift action_41 -action_196 (145#) = happyShift action_42 -action_196 (156#) = happyShift action_43 -action_196 (157#) = happyShift action_44 -action_196 (161#) = happyShift action_45 -action_196 (162#) = happyShift action_46 -action_196 (167#) = happyShift action_47 -action_196 (170#) = happyShift action_6 -action_196 (171#) = happyShift action_48 -action_196 (172#) = happyShift action_49 -action_196 (173#) = happyShift action_50 -action_196 (174#) = happyShift action_51 -action_196 (8#) = happyGoto action_10 -action_196 (9#) = happyGoto action_11 -action_196 (10#) = happyGoto action_12 -action_196 (11#) = happyGoto action_13 -action_196 (12#) = happyGoto action_14 -action_196 (58#) = happyGoto action_15 -action_196 (59#) = happyGoto action_16 -action_196 (60#) = happyGoto action_17 -action_196 (61#) = happyGoto action_18 -action_196 (62#) = happyGoto action_19 -action_196 (63#) = happyGoto action_306 -action_196 (64#) = happyGoto action_21 -action_196 (72#) = happyGoto action_22 -action_196 (77#) = happyGoto action_23 -action_196 x = happyTcHack x happyFail - -action_197 (96#) = happyShift action_24 -action_197 (98#) = happyShift action_25 -action_197 (104#) = happyShift action_26 -action_197 (109#) = happyShift action_27 -action_197 (110#) = happyShift action_28 -action_197 (111#) = happyShift action_29 -action_197 (114#) = happyShift action_30 -action_197 (119#) = happyShift action_31 -action_197 (124#) = happyShift action_32 -action_197 (125#) = happyShift action_33 -action_197 (126#) = happyShift action_34 -action_197 (127#) = happyShift action_35 -action_197 (128#) = happyShift action_36 -action_197 (129#) = happyShift action_37 -action_197 (131#) = happyShift action_38 -action_197 (134#) = happyShift action_39 -action_197 (137#) = happyShift action_40 -action_197 (140#) = happyShift action_41 -action_197 (145#) = happyShift action_42 -action_197 (156#) = happyShift action_43 -action_197 (157#) = happyShift action_44 -action_197 (161#) = happyShift action_45 -action_197 (162#) = happyShift action_46 -action_197 (167#) = happyShift action_47 -action_197 (170#) = happyShift action_6 -action_197 (171#) = happyShift action_48 -action_197 (172#) = happyShift action_49 -action_197 (173#) = happyShift action_50 -action_197 (174#) = happyShift action_51 -action_197 (8#) = happyGoto action_10 -action_197 (9#) = happyGoto action_11 -action_197 (10#) = happyGoto action_12 -action_197 (11#) = happyGoto action_13 -action_197 (12#) = happyGoto action_14 -action_197 (58#) = happyGoto action_15 -action_197 (59#) = happyGoto action_16 -action_197 (60#) = happyGoto action_17 -action_197 (61#) = happyGoto action_18 -action_197 (62#) = happyGoto action_19 -action_197 (63#) = happyGoto action_305 -action_197 (64#) = happyGoto action_21 -action_197 (72#) = happyGoto action_22 -action_197 (77#) = happyGoto action_23 -action_197 x = happyTcHack x happyFail - -action_198 (94#) = happyShift action_304 -action_198 x = happyTcHack x happyFail - -action_199 (94#) = happyShift action_303 -action_199 x = happyTcHack x happyReduce_194 - -action_200 (97#) = happyShift action_302 -action_200 x = happyTcHack x happyFail - -action_201 (109#) = happyShift action_165 -action_201 x = happyTcHack x happyFail - -action_202 (96#) = happyShift action_106 -action_202 (97#) = happyShift action_155 -action_202 (98#) = happyShift action_107 -action_202 (103#) = happyShift action_156 -action_202 (104#) = happyShift action_108 -action_202 (107#) = happyShift action_300 -action_202 (108#) = happyReduce_203 -action_202 (110#) = happyShift action_109 -action_202 (111#) = happyShift action_110 -action_202 (113#) = happyShift action_301 -action_202 (114#) = happyShift action_111 -action_202 (116#) = happyReduce_203 -action_202 (117#) = happyReduce_203 -action_202 (120#) = happyReduce_203 -action_202 (121#) = happyShift action_112 -action_202 (170#) = happyShift action_6 -action_202 (171#) = happyShift action_48 -action_202 (172#) = happyShift action_49 -action_202 (174#) = happyShift action_51 -action_202 (8#) = happyGoto action_101 -action_202 (9#) = happyGoto action_102 -action_202 (10#) = happyGoto action_103 -action_202 (12#) = happyGoto action_104 -action_202 (67#) = happyGoto action_188 -action_202 (74#) = happyGoto action_299 -action_202 x = happyTcHack x happyReduce_128 - -action_203 (108#) = happyShift action_296 -action_203 (117#) = happyShift action_297 -action_203 (120#) = happyShift action_298 -action_203 x = happyTcHack x happyFail - -action_204 (94#) = happyShift action_295 -action_204 x = happyTcHack x happyReduce_250 - -action_205 (97#) = happyShift action_294 -action_205 x = happyTcHack x happyFail - -action_206 (96#) = happyShift action_106 -action_206 (98#) = happyShift action_107 -action_206 (104#) = happyShift action_108 -action_206 (106#) = happyShift action_176 -action_206 (110#) = happyShift action_109 -action_206 (111#) = happyShift action_110 -action_206 (114#) = happyShift action_111 -action_206 (121#) = happyShift action_112 -action_206 (170#) = happyShift action_6 -action_206 (171#) = happyShift action_48 -action_206 (172#) = happyShift action_49 -action_206 (174#) = happyShift action_51 -action_206 (8#) = happyGoto action_101 -action_206 (9#) = happyGoto action_102 -action_206 (10#) = happyGoto action_103 -action_206 (12#) = happyGoto action_170 -action_206 (67#) = happyGoto action_171 -action_206 (68#) = happyGoto action_172 -action_206 (69#) = happyGoto action_203 -action_206 (82#) = happyGoto action_204 -action_206 (83#) = happyGoto action_293 -action_206 x = happyTcHack x happyFail - -action_207 (96#) = happyShift action_24 -action_207 (98#) = happyShift action_25 -action_207 (104#) = happyShift action_26 -action_207 (109#) = happyShift action_27 -action_207 (110#) = happyShift action_28 -action_207 (111#) = happyShift action_29 -action_207 (114#) = happyShift action_30 -action_207 (119#) = happyShift action_31 -action_207 (124#) = happyShift action_32 -action_207 (125#) = happyShift action_33 -action_207 (126#) = happyShift action_34 -action_207 (127#) = happyShift action_35 -action_207 (128#) = happyShift action_36 -action_207 (129#) = happyShift action_37 -action_207 (131#) = happyShift action_38 -action_207 (134#) = happyShift action_39 -action_207 (137#) = happyShift action_40 -action_207 (140#) = happyShift action_41 -action_207 (145#) = happyShift action_42 -action_207 (156#) = happyShift action_43 -action_207 (157#) = happyShift action_44 -action_207 (161#) = happyShift action_45 -action_207 (162#) = happyShift action_46 -action_207 (167#) = happyShift action_47 -action_207 (170#) = happyShift action_6 -action_207 (171#) = happyShift action_48 -action_207 (172#) = happyShift action_49 -action_207 (173#) = happyShift action_50 -action_207 (174#) = happyShift action_51 -action_207 (8#) = happyGoto action_10 -action_207 (9#) = happyGoto action_11 -action_207 (10#) = happyGoto action_12 -action_207 (11#) = happyGoto action_13 -action_207 (12#) = happyGoto action_14 -action_207 (58#) = happyGoto action_15 -action_207 (59#) = happyGoto action_16 -action_207 (60#) = happyGoto action_17 -action_207 (61#) = happyGoto action_18 -action_207 (62#) = happyGoto action_19 -action_207 (63#) = happyGoto action_199 -action_207 (64#) = happyGoto action_21 -action_207 (65#) = happyGoto action_292 -action_207 (72#) = happyGoto action_22 -action_207 (77#) = happyGoto action_23 -action_207 x = happyTcHack x happyReduce_193 - -action_208 (97#) = happyShift action_291 -action_208 x = happyTcHack x happyFail - -action_209 x = happyTcHack x happyReduce_49 - -action_210 (104#) = happyShift action_290 -action_210 (174#) = happyShift action_51 -action_210 (12#) = happyGoto action_287 -action_210 (36#) = happyGoto action_288 -action_210 (46#) = happyGoto action_289 -action_210 x = happyTcHack x happyFail - -action_211 (174#) = happyShift action_51 -action_211 (12#) = happyGoto action_283 -action_211 (37#) = happyGoto action_276 -action_211 (38#) = happyGoto action_284 -action_211 (47#) = happyGoto action_285 -action_211 (48#) = happyGoto action_286 -action_211 (53#) = happyGoto action_278 -action_211 x = happyTcHack x happyFail - -action_212 (104#) = happyShift action_257 -action_212 (174#) = happyShift action_51 -action_212 (12#) = happyGoto action_252 -action_212 (34#) = happyGoto action_253 -action_212 (45#) = happyGoto action_282 -action_212 (54#) = happyGoto action_255 -action_212 (55#) = happyGoto action_256 -action_212 x = happyTcHack x happyFail - -action_213 (174#) = happyShift action_51 -action_213 (12#) = happyGoto action_279 -action_213 (44#) = happyGoto action_280 -action_213 (51#) = happyGoto action_281 -action_213 x = happyTcHack x happyFail - -action_214 (174#) = happyShift action_51 -action_214 (12#) = happyGoto action_87 -action_214 (37#) = happyGoto action_276 -action_214 (47#) = happyGoto action_277 -action_214 (53#) = happyGoto action_278 -action_214 x = happyTcHack x happyFail - -action_215 (104#) = happyShift action_257 -action_215 (174#) = happyShift action_51 -action_215 (12#) = happyGoto action_252 -action_215 (34#) = happyGoto action_253 -action_215 (45#) = happyGoto action_275 -action_215 (54#) = happyGoto action_255 -action_215 (55#) = happyGoto action_256 -action_215 x = happyTcHack x happyFail - -action_216 (104#) = happyShift action_257 -action_216 (174#) = happyShift action_51 -action_216 (12#) = happyGoto action_252 -action_216 (43#) = happyGoto action_260 -action_216 (50#) = happyGoto action_274 -action_216 (54#) = happyGoto action_262 -action_216 (55#) = happyGoto action_263 -action_216 x = happyTcHack x happyFail - -action_217 (104#) = happyShift action_257 -action_217 (174#) = happyShift action_51 -action_217 (12#) = happyGoto action_252 -action_217 (34#) = happyGoto action_253 -action_217 (45#) = happyGoto action_273 -action_217 (54#) = happyGoto action_255 -action_217 (55#) = happyGoto action_256 -action_217 x = happyTcHack x happyFail - -action_218 (104#) = happyShift action_257 -action_218 (174#) = happyShift action_51 -action_218 (12#) = happyGoto action_252 -action_218 (34#) = happyGoto action_253 -action_218 (45#) = happyGoto action_272 -action_218 (54#) = happyGoto action_255 -action_218 (55#) = happyGoto action_256 -action_218 x = happyTcHack x happyFail - -action_219 (104#) = happyShift action_257 -action_219 (174#) = happyShift action_51 -action_219 (12#) = happyGoto action_252 -action_219 (34#) = happyGoto action_253 -action_219 (45#) = happyGoto action_271 -action_219 (54#) = happyGoto action_255 -action_219 (55#) = happyGoto action_256 -action_219 x = happyTcHack x happyFail - -action_220 (174#) = happyShift action_51 -action_220 (12#) = happyGoto action_270 -action_220 x = happyTcHack x happyFail - -action_221 (174#) = happyShift action_51 -action_221 (12#) = happyGoto action_267 -action_221 (41#) = happyGoto action_268 -action_221 (49#) = happyGoto action_269 -action_221 x = happyTcHack x happyFail - -action_222 (104#) = happyShift action_257 -action_222 (174#) = happyShift action_51 -action_222 (12#) = happyGoto action_252 -action_222 (34#) = happyGoto action_253 -action_222 (45#) = happyGoto action_266 -action_222 (54#) = happyGoto action_255 -action_222 (55#) = happyGoto action_256 -action_222 x = happyTcHack x happyFail - -action_223 (104#) = happyShift action_257 -action_223 (132#) = happyShift action_264 -action_223 (138#) = happyShift action_265 -action_223 (174#) = happyShift action_51 -action_223 (12#) = happyGoto action_252 -action_223 (43#) = happyGoto action_260 -action_223 (50#) = happyGoto action_261 -action_223 (54#) = happyGoto action_262 -action_223 (55#) = happyGoto action_263 -action_223 x = happyTcHack x happyFail - -action_224 (174#) = happyShift action_51 -action_224 (12#) = happyGoto action_259 -action_224 x = happyTcHack x happyFail - -action_225 (104#) = happyShift action_257 -action_225 (174#) = happyShift action_51 -action_225 (12#) = happyGoto action_252 -action_225 (34#) = happyGoto action_253 -action_225 (45#) = happyGoto action_258 -action_225 (54#) = happyGoto action_255 -action_225 (55#) = happyGoto action_256 -action_225 x = happyTcHack x happyFail - -action_226 (104#) = happyShift action_257 -action_226 (174#) = happyShift action_51 -action_226 (12#) = happyGoto action_252 -action_226 (34#) = happyGoto action_253 -action_226 (45#) = happyGoto action_254 -action_226 (54#) = happyGoto action_255 -action_226 (55#) = happyGoto action_256 -action_226 x = happyTcHack x happyFail - -action_227 x = happyTcHack x happyReduce_269 - -action_228 x = happyTcHack x happyReduce_270 - -action_229 x = happyTcHack x happyReduce_271 - -action_230 (106#) = happyShift action_74 -action_230 (107#) = happyShift action_75 -action_230 (123#) = happyShift action_76 -action_230 (171#) = happyShift action_48 -action_230 (174#) = happyShift action_51 -action_230 (9#) = happyGoto action_70 -action_230 (12#) = happyGoto action_71 -action_230 (92#) = happyGoto action_72 -action_230 (93#) = happyGoto action_251 -action_230 x = happyTcHack x happyReduce_273 - -action_231 x = happyTcHack x happyReduce_272 - -action_232 (100#) = happyShift action_250 -action_232 x = happyTcHack x happyFail - -action_233 x = happyTcHack x happyReduce_35 - -action_234 x = happyTcHack x happyReduce_36 - -action_235 (150#) = happyShift action_249 -action_235 x = happyTcHack x happyFail - -action_236 (150#) = happyShift action_248 -action_236 x = happyTcHack x happyFail - -action_237 x = happyTcHack x happyReduce_34 - -action_238 (96#) = happyReduce_51 -action_238 (151#) = happyReduce_51 -action_238 (160#) = happyShift action_246 -action_238 (165#) = happyShift action_247 -action_238 (174#) = happyShift action_51 -action_238 (12#) = happyGoto action_241 -action_238 (24#) = happyGoto action_242 -action_238 (26#) = happyGoto action_243 -action_238 (32#) = happyGoto action_244 -action_238 (33#) = happyGoto action_245 -action_238 x = happyTcHack x happyReduce_65 - -action_239 (96#) = happyShift action_240 -action_239 x = happyTcHack x happyFail - -action_240 (130#) = happyShift action_418 -action_240 x = happyTcHack x happyFail - -action_241 (104#) = happyShift action_416 -action_241 (106#) = happyShift action_417 -action_241 x = happyTcHack x happyReduce_68 - -action_242 x = happyTcHack x happyReduce_15 - -action_243 (151#) = happyShift action_356 -action_243 (28#) = happyGoto action_415 -action_243 x = happyTcHack x happyReduce_55 - -action_244 (102#) = happyShift action_414 -action_244 x = happyTcHack x happyReduce_41 - -action_245 (103#) = happyShift action_352 -action_245 (169#) = happyShift action_413 -action_245 x = happyTcHack x happyReduce_66 - -action_246 (174#) = happyShift action_51 -action_246 (12#) = happyGoto action_412 -action_246 x = happyTcHack x happyFail - -action_247 (174#) = happyShift action_51 -action_247 (12#) = happyGoto action_241 -action_247 (32#) = happyGoto action_411 -action_247 (33#) = happyGoto action_350 -action_247 x = happyTcHack x happyReduce_65 - -action_248 (174#) = happyShift action_51 -action_248 (12#) = happyGoto action_410 -action_248 x = happyTcHack x happyFail - -action_249 (174#) = happyShift action_51 -action_249 (12#) = happyGoto action_409 -action_249 x = happyTcHack x happyFail - -action_250 (98#) = happyShift action_408 -action_250 (174#) = happyShift action_51 -action_250 (12#) = happyGoto action_406 -action_250 (29#) = happyGoto action_407 -action_250 x = happyTcHack x happyFail - -action_251 x = happyTcHack x happyReduce_274 - -action_252 x = happyTcHack x happyReduce_130 - -action_253 (94#) = happyShift action_405 -action_253 x = happyTcHack x happyFail - -action_254 x = happyTcHack x happyReduce_93 - -action_255 (96#) = happyShift action_106 -action_255 (98#) = happyShift action_107 -action_255 (103#) = happyShift action_398 -action_255 (104#) = happyShift action_108 -action_255 (110#) = happyShift action_109 -action_255 (111#) = happyShift action_110 -action_255 (114#) = happyShift action_111 -action_255 (121#) = happyShift action_112 -action_255 (170#) = happyShift action_6 -action_255 (171#) = happyShift action_48 -action_255 (172#) = happyShift action_49 -action_255 (174#) = happyShift action_51 -action_255 (8#) = happyGoto action_101 -action_255 (9#) = happyGoto action_102 -action_255 (10#) = happyGoto action_103 -action_255 (12#) = happyGoto action_104 -action_255 (67#) = happyGoto action_188 -action_255 (74#) = happyGoto action_404 -action_255 x = happyTcHack x happyReduce_132 - -action_256 (95#) = happyShift action_402 -action_256 (100#) = happyShift action_403 -action_256 x = happyTcHack x happyFail - -action_257 (174#) = happyShift action_51 -action_257 (12#) = happyGoto action_401 -action_257 x = happyTcHack x happyFail - -action_258 x = happyTcHack x happyReduce_80 - -action_259 (94#) = happyShift action_400 -action_259 x = happyTcHack x happyFail - -action_260 (94#) = happyShift action_399 -action_260 x = happyTcHack x happyFail - -action_261 x = happyTcHack x happyReduce_89 - -action_262 (103#) = happyShift action_398 -action_262 x = happyTcHack x happyReduce_132 - -action_263 (95#) = happyShift action_397 -action_263 x = happyTcHack x happyFail - -action_264 (104#) = happyShift action_257 -action_264 (174#) = happyShift action_51 -action_264 (12#) = happyGoto action_252 -action_264 (43#) = happyGoto action_260 -action_264 (50#) = happyGoto action_396 -action_264 (54#) = happyGoto action_262 -action_264 (55#) = happyGoto action_263 -action_264 x = happyTcHack x happyFail - -action_265 (104#) = happyShift action_257 -action_265 (174#) = happyShift action_51 -action_265 (12#) = happyGoto action_252 -action_265 (43#) = happyGoto action_260 -action_265 (50#) = happyGoto action_395 -action_265 (54#) = happyGoto action_262 -action_265 (55#) = happyGoto action_263 -action_265 x = happyTcHack x happyFail - -action_266 x = happyTcHack x happyReduce_91 - -action_267 (95#) = happyShift action_394 -action_267 x = happyTcHack x happyReduce_107 - -action_268 (94#) = happyShift action_393 -action_268 x = happyTcHack x happyFail - -action_269 x = happyTcHack x happyReduce_81 - -action_270 (95#) = happyShift action_392 -action_270 x = happyTcHack x happyFail - -action_271 x = happyTcHack x happyReduce_82 - -action_272 x = happyTcHack x happyReduce_90 - -action_273 x = happyTcHack x happyReduce_84 - -action_274 x = happyTcHack x happyReduce_83 - -action_275 x = happyTcHack x happyReduce_85 - -action_276 (94#) = happyShift action_391 -action_276 x = happyTcHack x happyFail - -action_277 x = happyTcHack x happyReduce_76 - -action_278 (100#) = happyShift action_390 -action_278 x = happyTcHack x happyFail - -action_279 (95#) = happyShift action_389 -action_279 x = happyTcHack x happyFail - -action_280 (94#) = happyShift action_388 -action_280 x = happyTcHack x happyFail - -action_281 x = happyTcHack x happyReduce_88 - -action_282 x = happyTcHack x happyReduce_78 - -action_283 (95#) = happyShift action_387 -action_283 (103#) = happyShift action_156 -action_283 x = happyTcHack x happyReduce_128 - -action_284 (94#) = happyShift action_386 -action_284 x = happyTcHack x happyFail - -action_285 x = happyTcHack x happyReduce_77 - -action_286 x = happyTcHack x happyReduce_79 - -action_287 (89#) = happyGoto action_385 -action_287 x = happyTcHack x happyReduce_262 - -action_288 (94#) = happyShift action_384 -action_288 x = happyTcHack x happyFail - -action_289 x = happyTcHack x happyReduce_75 - -action_290 (174#) = happyShift action_51 -action_290 (12#) = happyGoto action_383 -action_290 x = happyTcHack x happyFail - -action_291 x = happyTcHack x happyReduce_167 - -action_292 (105#) = happyShift action_382 -action_292 x = happyTcHack x happyFail - -action_293 (97#) = happyShift action_381 -action_293 x = happyTcHack x happyFail - -action_294 x = happyTcHack x happyReduce_163 - -action_295 (96#) = happyShift action_106 -action_295 (98#) = happyShift action_107 -action_295 (104#) = happyShift action_108 -action_295 (106#) = happyShift action_176 -action_295 (110#) = happyShift action_109 -action_295 (111#) = happyShift action_110 -action_295 (114#) = happyShift action_111 -action_295 (121#) = happyShift action_112 -action_295 (170#) = happyShift action_6 -action_295 (171#) = happyShift action_48 -action_295 (172#) = happyShift action_49 -action_295 (174#) = happyShift action_51 -action_295 (8#) = happyGoto action_101 -action_295 (9#) = happyGoto action_102 -action_295 (10#) = happyGoto action_103 -action_295 (12#) = happyGoto action_170 -action_295 (67#) = happyGoto action_171 -action_295 (68#) = happyGoto action_172 -action_295 (69#) = happyGoto action_203 -action_295 (82#) = happyGoto action_204 -action_295 (83#) = happyGoto action_380 -action_295 x = happyTcHack x happyFail - -action_296 (96#) = happyShift action_106 -action_296 (98#) = happyShift action_107 -action_296 (104#) = happyShift action_108 -action_296 (106#) = happyShift action_176 -action_296 (110#) = happyShift action_109 -action_296 (111#) = happyShift action_110 -action_296 (114#) = happyShift action_111 -action_296 (121#) = happyShift action_112 -action_296 (170#) = happyShift action_6 -action_296 (171#) = happyShift action_48 -action_296 (172#) = happyShift action_49 -action_296 (174#) = happyShift action_51 -action_296 (8#) = happyGoto action_101 -action_296 (9#) = happyGoto action_102 -action_296 (10#) = happyGoto action_103 -action_296 (12#) = happyGoto action_170 -action_296 (67#) = happyGoto action_171 -action_296 (68#) = happyGoto action_379 -action_296 x = happyTcHack x happyFail - -action_297 (96#) = happyShift action_106 -action_297 (98#) = happyShift action_107 -action_297 (104#) = happyShift action_108 -action_297 (106#) = happyShift action_176 -action_297 (110#) = happyShift action_109 -action_297 (111#) = happyShift action_110 -action_297 (114#) = happyShift action_111 -action_297 (121#) = happyShift action_112 -action_297 (170#) = happyShift action_6 -action_297 (171#) = happyShift action_48 -action_297 (172#) = happyShift action_49 -action_297 (174#) = happyShift action_51 -action_297 (8#) = happyGoto action_101 -action_297 (9#) = happyGoto action_102 -action_297 (10#) = happyGoto action_103 -action_297 (12#) = happyGoto action_170 -action_297 (67#) = happyGoto action_171 -action_297 (68#) = happyGoto action_378 -action_297 x = happyTcHack x happyFail - -action_298 (96#) = happyShift action_24 -action_298 (98#) = happyShift action_25 -action_298 (104#) = happyShift action_26 -action_298 (109#) = happyShift action_27 -action_298 (110#) = happyShift action_28 -action_298 (111#) = happyShift action_29 -action_298 (114#) = happyShift action_30 -action_298 (119#) = happyShift action_31 -action_298 (124#) = happyShift action_32 -action_298 (125#) = happyShift action_33 -action_298 (126#) = happyShift action_34 -action_298 (127#) = happyShift action_35 -action_298 (128#) = happyShift action_36 -action_298 (129#) = happyShift action_37 -action_298 (131#) = happyShift action_38 -action_298 (134#) = happyShift action_39 -action_298 (137#) = happyShift action_40 -action_298 (140#) = happyShift action_41 -action_298 (145#) = happyShift action_42 -action_298 (156#) = happyShift action_43 -action_298 (157#) = happyShift action_44 -action_298 (161#) = happyShift action_45 -action_298 (162#) = happyShift action_46 -action_298 (167#) = happyShift action_47 -action_298 (170#) = happyShift action_6 -action_298 (171#) = happyShift action_48 -action_298 (172#) = happyShift action_49 -action_298 (173#) = happyShift action_50 -action_298 (174#) = happyShift action_51 -action_298 (8#) = happyGoto action_10 -action_298 (9#) = happyGoto action_11 -action_298 (10#) = happyGoto action_12 -action_298 (11#) = happyGoto action_13 -action_298 (12#) = happyGoto action_14 -action_298 (58#) = happyGoto action_15 -action_298 (59#) = happyGoto action_16 -action_298 (60#) = happyGoto action_17 -action_298 (61#) = happyGoto action_18 -action_298 (62#) = happyGoto action_19 -action_298 (63#) = happyGoto action_377 -action_298 (64#) = happyGoto action_21 -action_298 (72#) = happyGoto action_22 -action_298 (77#) = happyGoto action_23 -action_298 x = happyTcHack x happyFail - -action_299 x = happyTcHack x happyReduce_212 - -action_300 (174#) = happyShift action_51 -action_300 (12#) = happyGoto action_376 -action_300 x = happyTcHack x happyFail - -action_301 (96#) = happyShift action_106 -action_301 (98#) = happyShift action_107 -action_301 (104#) = happyShift action_108 -action_301 (110#) = happyShift action_109 -action_301 (111#) = happyShift action_110 -action_301 (114#) = happyShift action_111 -action_301 (121#) = happyShift action_112 -action_301 (170#) = happyShift action_6 -action_301 (171#) = happyShift action_48 -action_301 (172#) = happyShift action_49 -action_301 (174#) = happyShift action_51 -action_301 (8#) = happyGoto action_101 -action_301 (9#) = happyGoto action_102 -action_301 (10#) = happyGoto action_103 -action_301 (12#) = happyGoto action_104 -action_301 (67#) = happyGoto action_375 -action_301 x = happyTcHack x happyFail - -action_302 x = happyTcHack x happyReduce_169 - -action_303 (96#) = happyShift action_24 -action_303 (98#) = happyShift action_25 -action_303 (104#) = happyShift action_26 -action_303 (109#) = happyShift action_27 -action_303 (110#) = happyShift action_28 -action_303 (111#) = happyShift action_29 -action_303 (114#) = happyShift action_30 -action_303 (119#) = happyShift action_31 -action_303 (124#) = happyShift action_32 -action_303 (125#) = happyShift action_33 -action_303 (126#) = happyShift action_34 -action_303 (127#) = happyShift action_35 -action_303 (128#) = happyShift action_36 -action_303 (129#) = happyShift action_37 -action_303 (131#) = happyShift action_38 -action_303 (134#) = happyShift action_39 -action_303 (137#) = happyShift action_40 -action_303 (140#) = happyShift action_41 -action_303 (145#) = happyShift action_42 -action_303 (156#) = happyShift action_43 -action_303 (157#) = happyShift action_44 -action_303 (161#) = happyShift action_45 -action_303 (162#) = happyShift action_46 -action_303 (167#) = happyShift action_47 -action_303 (170#) = happyShift action_6 -action_303 (171#) = happyShift action_48 -action_303 (172#) = happyShift action_49 -action_303 (173#) = happyShift action_50 -action_303 (174#) = happyShift action_51 -action_303 (8#) = happyGoto action_10 -action_303 (9#) = happyGoto action_11 -action_303 (10#) = happyGoto action_12 -action_303 (11#) = happyGoto action_13 -action_303 (12#) = happyGoto action_14 -action_303 (58#) = happyGoto action_15 -action_303 (59#) = happyGoto action_16 -action_303 (60#) = happyGoto action_17 -action_303 (61#) = happyGoto action_18 -action_303 (62#) = happyGoto action_19 -action_303 (63#) = happyGoto action_199 -action_303 (64#) = happyGoto action_21 -action_303 (65#) = happyGoto action_374 -action_303 (72#) = happyGoto action_22 -action_303 (77#) = happyGoto action_23 -action_303 x = happyTcHack x happyReduce_193 - -action_304 (96#) = happyShift action_24 -action_304 (98#) = happyShift action_25 -action_304 (104#) = happyShift action_26 -action_304 (109#) = happyShift action_27 -action_304 (110#) = happyShift action_28 -action_304 (111#) = happyShift action_29 -action_304 (114#) = happyShift action_30 -action_304 (119#) = happyShift action_31 -action_304 (124#) = happyShift action_32 -action_304 (125#) = happyShift action_33 -action_304 (126#) = happyShift action_34 -action_304 (127#) = happyShift action_35 -action_304 (128#) = happyShift action_36 -action_304 (129#) = happyShift action_37 -action_304 (131#) = happyShift action_38 -action_304 (134#) = happyShift action_39 -action_304 (137#) = happyShift action_40 -action_304 (140#) = happyShift action_41 -action_304 (145#) = happyShift action_42 -action_304 (156#) = happyShift action_43 -action_304 (157#) = happyShift action_44 -action_304 (161#) = happyShift action_45 -action_304 (162#) = happyShift action_46 -action_304 (167#) = happyShift action_47 -action_304 (170#) = happyShift action_6 -action_304 (171#) = happyShift action_48 -action_304 (172#) = happyShift action_49 -action_304 (173#) = happyShift action_50 -action_304 (174#) = happyShift action_51 -action_304 (8#) = happyGoto action_10 -action_304 (9#) = happyGoto action_11 -action_304 (10#) = happyGoto action_12 -action_304 (11#) = happyGoto action_13 -action_304 (12#) = happyGoto action_14 -action_304 (58#) = happyGoto action_15 -action_304 (59#) = happyGoto action_16 -action_304 (60#) = happyGoto action_17 -action_304 (61#) = happyGoto action_18 -action_304 (62#) = happyGoto action_19 -action_304 (63#) = happyGoto action_371 -action_304 (64#) = happyGoto action_21 -action_304 (72#) = happyGoto action_22 -action_304 (77#) = happyGoto action_23 -action_304 (86#) = happyGoto action_372 -action_304 (87#) = happyGoto action_373 -action_304 x = happyTcHack x happyReduce_257 - -action_305 (95#) = happyShift action_370 -action_305 x = happyTcHack x happyReduce_134 - -action_306 x = happyTcHack x happyReduce_135 - -action_307 x = happyTcHack x happyReduce_139 - -action_308 x = happyTcHack x happyReduce_187 - -action_309 (140#) = happyShift action_369 -action_309 x = happyTcHack x happyFail - -action_310 x = happyTcHack x happyReduce_189 - -action_311 (96#) = happyShift action_106 -action_311 (98#) = happyShift action_107 -action_311 (104#) = happyShift action_108 -action_311 (110#) = happyShift action_109 -action_311 (111#) = happyShift action_110 -action_311 (114#) = happyShift action_111 -action_311 (121#) = happyShift action_112 -action_311 (170#) = happyShift action_6 -action_311 (171#) = happyShift action_48 -action_311 (172#) = happyShift action_49 -action_311 (174#) = happyShift action_51 -action_311 (8#) = happyGoto action_101 -action_311 (9#) = happyGoto action_102 -action_311 (10#) = happyGoto action_103 -action_311 (12#) = happyGoto action_104 -action_311 (67#) = happyGoto action_188 -action_311 (74#) = happyGoto action_189 -action_311 (84#) = happyGoto action_190 -action_311 (85#) = happyGoto action_368 -action_311 x = happyTcHack x happyReduce_253 - -action_312 (96#) = happyShift action_24 -action_312 (98#) = happyShift action_25 -action_312 (104#) = happyShift action_26 -action_312 (109#) = happyShift action_27 -action_312 (110#) = happyShift action_28 -action_312 (111#) = happyShift action_29 -action_312 (114#) = happyShift action_30 -action_312 (119#) = happyShift action_31 -action_312 (124#) = happyShift action_32 -action_312 (125#) = happyShift action_33 -action_312 (126#) = happyShift action_34 -action_312 (127#) = happyShift action_35 -action_312 (128#) = happyShift action_36 -action_312 (129#) = happyShift action_37 -action_312 (131#) = happyShift action_38 -action_312 (134#) = happyShift action_39 -action_312 (137#) = happyShift action_40 -action_312 (140#) = happyShift action_41 -action_312 (145#) = happyShift action_42 -action_312 (156#) = happyShift action_43 -action_312 (157#) = happyShift action_44 -action_312 (161#) = happyShift action_45 -action_312 (162#) = happyShift action_46 -action_312 (167#) = happyShift action_47 -action_312 (170#) = happyShift action_6 -action_312 (171#) = happyShift action_48 -action_312 (172#) = happyShift action_49 -action_312 (173#) = happyShift action_50 -action_312 (174#) = happyShift action_51 -action_312 (8#) = happyGoto action_10 -action_312 (9#) = happyGoto action_11 -action_312 (10#) = happyGoto action_12 -action_312 (11#) = happyGoto action_13 -action_312 (12#) = happyGoto action_14 -action_312 (58#) = happyGoto action_15 -action_312 (59#) = happyGoto action_16 -action_312 (60#) = happyGoto action_17 -action_312 (61#) = happyGoto action_18 -action_312 (62#) = happyGoto action_19 -action_312 (63#) = happyGoto action_367 -action_312 (64#) = happyGoto action_21 -action_312 (72#) = happyGoto action_22 -action_312 (77#) = happyGoto action_23 -action_312 x = happyTcHack x happyFail - -action_313 x = happyTcHack x happyReduce_233 - -action_314 (96#) = happyShift action_106 -action_314 (98#) = happyShift action_107 -action_314 (104#) = happyShift action_108 -action_314 (106#) = happyShift action_176 -action_314 (110#) = happyShift action_109 -action_314 (111#) = happyShift action_110 -action_314 (114#) = happyShift action_111 -action_314 (121#) = happyShift action_112 -action_314 (170#) = happyShift action_6 -action_314 (171#) = happyShift action_48 -action_314 (172#) = happyShift action_49 -action_314 (174#) = happyShift action_51 -action_314 (8#) = happyGoto action_101 -action_314 (9#) = happyGoto action_102 -action_314 (10#) = happyGoto action_103 -action_314 (12#) = happyGoto action_170 -action_314 (67#) = happyGoto action_171 -action_314 (68#) = happyGoto action_172 -action_314 (69#) = happyGoto action_203 -action_314 (82#) = happyGoto action_204 -action_314 (83#) = happyGoto action_366 -action_314 x = happyTcHack x happyFail - -action_315 x = happyTcHack x happyReduce_238 - -action_316 x = happyTcHack x happyReduce_182 - -action_317 (96#) = happyShift action_24 -action_317 (98#) = happyShift action_25 -action_317 (104#) = happyShift action_26 -action_317 (109#) = happyShift action_27 -action_317 (110#) = happyShift action_28 -action_317 (111#) = happyShift action_29 -action_317 (114#) = happyShift action_30 -action_317 (119#) = happyShift action_31 -action_317 (124#) = happyShift action_32 -action_317 (125#) = happyShift action_33 -action_317 (126#) = happyShift action_34 -action_317 (127#) = happyShift action_35 -action_317 (128#) = happyShift action_36 -action_317 (129#) = happyShift action_37 -action_317 (131#) = happyShift action_38 -action_317 (134#) = happyShift action_39 -action_317 (137#) = happyShift action_40 -action_317 (140#) = happyShift action_41 -action_317 (145#) = happyShift action_42 -action_317 (156#) = happyShift action_43 -action_317 (157#) = happyShift action_44 -action_317 (161#) = happyShift action_45 -action_317 (162#) = happyShift action_46 -action_317 (167#) = happyShift action_47 -action_317 (170#) = happyShift action_6 -action_317 (171#) = happyShift action_48 -action_317 (172#) = happyShift action_49 -action_317 (173#) = happyShift action_50 -action_317 (174#) = happyShift action_51 -action_317 (8#) = happyGoto action_10 -action_317 (9#) = happyGoto action_11 -action_317 (10#) = happyGoto action_12 -action_317 (11#) = happyGoto action_13 -action_317 (12#) = happyGoto action_14 -action_317 (58#) = happyGoto action_15 -action_317 (59#) = happyGoto action_16 -action_317 (60#) = happyGoto action_17 -action_317 (61#) = happyGoto action_18 -action_317 (62#) = happyGoto action_19 -action_317 (63#) = happyGoto action_365 -action_317 (64#) = happyGoto action_21 -action_317 (72#) = happyGoto action_22 -action_317 (77#) = happyGoto action_23 -action_317 x = happyTcHack x happyFail - -action_318 x = happyTcHack x happyReduce_205 - -action_319 x = happyTcHack x happyReduce_209 - -action_320 (174#) = happyShift action_51 -action_320 (12#) = happyGoto action_87 -action_320 (53#) = happyGoto action_180 -action_320 (70#) = happyGoto action_181 -action_320 (73#) = happyGoto action_364 -action_320 x = happyTcHack x happyReduce_229 - -action_321 (96#) = happyShift action_106 -action_321 (98#) = happyShift action_107 -action_321 (104#) = happyShift action_108 -action_321 (106#) = happyShift action_176 -action_321 (110#) = happyShift action_109 -action_321 (111#) = happyShift action_110 -action_321 (114#) = happyShift action_111 -action_321 (121#) = happyShift action_112 -action_321 (170#) = happyShift action_6 -action_321 (171#) = happyShift action_48 -action_321 (172#) = happyShift action_49 -action_321 (174#) = happyShift action_51 -action_321 (8#) = happyGoto action_101 -action_321 (9#) = happyGoto action_102 -action_321 (10#) = happyGoto action_103 -action_321 (12#) = happyGoto action_170 -action_321 (67#) = happyGoto action_171 -action_321 (68#) = happyGoto action_172 -action_321 (69#) = happyGoto action_363 -action_321 x = happyTcHack x happyFail - -action_322 x = happyTcHack x happyReduce_204 - -action_323 x = happyTcHack x happyReduce_211 - -action_324 x = happyTcHack x happyReduce_199 - -action_325 x = happyTcHack x happyReduce_216 - -action_326 x = happyTcHack x happyReduce_210 - -action_327 (96#) = happyShift action_106 -action_327 (98#) = happyShift action_107 -action_327 (104#) = happyShift action_108 -action_327 (106#) = happyShift action_176 -action_327 (110#) = happyShift action_109 -action_327 (111#) = happyShift action_110 -action_327 (114#) = happyShift action_111 -action_327 (121#) = happyShift action_112 -action_327 (170#) = happyShift action_6 -action_327 (171#) = happyShift action_48 -action_327 (172#) = happyShift action_49 -action_327 (174#) = happyShift action_51 -action_327 (8#) = happyGoto action_101 -action_327 (9#) = happyGoto action_102 -action_327 (10#) = happyGoto action_103 -action_327 (12#) = happyGoto action_170 -action_327 (67#) = happyGoto action_171 -action_327 (68#) = happyGoto action_172 -action_327 (69#) = happyGoto action_173 -action_327 (79#) = happyGoto action_174 -action_327 (81#) = happyGoto action_362 -action_327 x = happyTcHack x happyReduce_246 - -action_328 x = happyTcHack x happyReduce_214 - -action_329 (174#) = happyShift action_51 -action_329 (12#) = happyGoto action_361 -action_329 x = happyTcHack x happyFail - -action_330 (112#) = happyShift action_360 -action_330 x = happyTcHack x happyFail - -action_331 x = happyTcHack x happyReduce_241 - -action_332 x = happyTcHack x happyReduce_245 - -action_333 x = happyTcHack x happyReduce_160 - -action_334 x = happyTcHack x happyReduce_150 - -action_335 x = happyTcHack x happyReduce_197 - -action_336 (99#) = happyShift action_359 -action_336 x = happyTcHack x happyFail - -action_337 x = happyTcHack x happyReduce_154 - -action_338 (97#) = happyShift action_358 -action_338 x = happyTcHack x happyFail - -action_339 x = happyTcHack x happyReduce_129 - -action_340 (97#) = happyShift action_357 -action_340 x = happyTcHack x happyFail - -action_341 x = happyTcHack x happyReduce_223 - -action_342 (97#) = happyShift action_155 -action_342 (103#) = happyShift action_156 -action_342 x = happyTcHack x happyReduce_128 - -action_343 x = happyTcHack x happyReduce_25 - -action_344 (151#) = happyShift action_356 -action_344 (28#) = happyGoto action_355 -action_344 x = happyTcHack x happyReduce_55 - -action_345 (102#) = happyShift action_354 -action_345 x = happyTcHack x happyReduce_27 - -action_346 (103#) = happyShift action_352 -action_346 (169#) = happyShift action_353 -action_346 x = happyTcHack x happyReduce_66 - -action_347 (174#) = happyShift action_51 -action_347 (12#) = happyGoto action_351 -action_347 x = happyTcHack x happyFail - -action_348 (174#) = happyShift action_51 -action_348 (12#) = happyGoto action_241 -action_348 (32#) = happyGoto action_349 -action_348 (33#) = happyGoto action_350 -action_348 x = happyTcHack x happyReduce_65 - -action_349 x = happyTcHack x happyReduce_33 - -action_350 (103#) = happyShift action_352 -action_350 x = happyTcHack x happyReduce_66 - -action_351 x = happyTcHack x happyReduce_32 - -action_352 (174#) = happyShift action_51 -action_352 (12#) = happyGoto action_241 -action_352 (32#) = happyGoto action_468 -action_352 (33#) = happyGoto action_350 -action_352 x = happyTcHack x happyReduce_65 - -action_353 (98#) = happyShift action_408 -action_353 (174#) = happyShift action_51 -action_353 (12#) = happyGoto action_406 -action_353 (27#) = happyGoto action_467 -action_353 (29#) = happyGoto action_425 -action_353 x = happyTcHack x happyReduce_52 - -action_354 (174#) = happyShift action_51 -action_354 (12#) = happyGoto action_241 -action_354 (33#) = happyGoto action_466 -action_354 x = happyTcHack x happyReduce_50 - -action_355 x = happyTcHack x happyReduce_26 - -action_356 (98#) = happyShift action_408 -action_356 (174#) = happyShift action_51 -action_356 (12#) = happyGoto action_406 -action_356 (27#) = happyGoto action_465 -action_356 (29#) = happyGoto action_425 -action_356 x = happyTcHack x happyReduce_52 - -action_357 x = happyTcHack x happyReduce_188 - -action_358 x = happyTcHack x happyReduce_159 - -action_359 x = happyTcHack x happyReduce_239 - -action_360 x = happyTcHack x happyReduce_155 - -action_361 x = happyTcHack x happyReduce_201 - -action_362 x = happyTcHack x happyReduce_248 - -action_363 (108#) = happyShift action_296 -action_363 (117#) = happyShift action_297 -action_363 x = happyTcHack x happyReduce_221 - -action_364 x = happyTcHack x happyReduce_231 - -action_365 x = happyTcHack x happyReduce_183 - -action_366 (97#) = happyShift action_464 -action_366 x = happyTcHack x happyFail - -action_367 x = happyTcHack x happyReduce_252 - -action_368 x = happyTcHack x happyReduce_255 - -action_369 (96#) = happyShift action_24 -action_369 (98#) = happyShift action_25 -action_369 (104#) = happyShift action_26 -action_369 (109#) = happyShift action_27 -action_369 (110#) = happyShift action_28 -action_369 (111#) = happyShift action_29 -action_369 (114#) = happyShift action_30 -action_369 (119#) = happyShift action_31 -action_369 (124#) = happyShift action_32 -action_369 (125#) = happyShift action_33 -action_369 (126#) = happyShift action_34 -action_369 (127#) = happyShift action_35 -action_369 (128#) = happyShift action_36 -action_369 (129#) = happyShift action_37 -action_369 (131#) = happyShift action_38 -action_369 (134#) = happyShift action_39 -action_369 (137#) = happyShift action_40 -action_369 (140#) = happyShift action_41 -action_369 (145#) = happyShift action_42 -action_369 (156#) = happyShift action_43 -action_369 (157#) = happyShift action_44 -action_369 (161#) = happyShift action_45 -action_369 (162#) = happyShift action_46 -action_369 (167#) = happyShift action_47 -action_369 (170#) = happyShift action_6 -action_369 (171#) = happyShift action_48 -action_369 (172#) = happyShift action_49 -action_369 (173#) = happyShift action_50 -action_369 (174#) = happyShift action_51 -action_369 (8#) = happyGoto action_10 -action_369 (9#) = happyGoto action_11 -action_369 (10#) = happyGoto action_12 -action_369 (11#) = happyGoto action_13 -action_369 (12#) = happyGoto action_14 -action_369 (58#) = happyGoto action_15 -action_369 (59#) = happyGoto action_16 -action_369 (60#) = happyGoto action_17 -action_369 (61#) = happyGoto action_18 -action_369 (62#) = happyGoto action_19 -action_369 (63#) = happyGoto action_463 -action_369 (64#) = happyGoto action_21 -action_369 (72#) = happyGoto action_22 -action_369 (77#) = happyGoto action_23 -action_369 x = happyTcHack x happyFail - -action_370 (96#) = happyShift action_24 -action_370 (98#) = happyShift action_25 -action_370 (104#) = happyShift action_26 -action_370 (109#) = happyShift action_27 -action_370 (110#) = happyShift action_28 -action_370 (111#) = happyShift action_29 -action_370 (114#) = happyShift action_30 -action_370 (119#) = happyShift action_31 -action_370 (124#) = happyShift action_32 -action_370 (125#) = happyShift action_33 -action_370 (126#) = happyShift action_34 -action_370 (127#) = happyShift action_35 -action_370 (128#) = happyShift action_36 -action_370 (129#) = happyShift action_37 -action_370 (131#) = happyShift action_38 -action_370 (134#) = happyShift action_39 -action_370 (137#) = happyShift action_40 -action_370 (140#) = happyShift action_41 -action_370 (145#) = happyShift action_42 -action_370 (156#) = happyShift action_43 -action_370 (157#) = happyShift action_44 -action_370 (161#) = happyShift action_45 -action_370 (162#) = happyShift action_46 -action_370 (167#) = happyShift action_47 -action_370 (170#) = happyShift action_6 -action_370 (171#) = happyShift action_48 -action_370 (172#) = happyShift action_49 -action_370 (173#) = happyShift action_50 -action_370 (174#) = happyShift action_51 -action_370 (8#) = happyGoto action_10 -action_370 (9#) = happyGoto action_11 -action_370 (10#) = happyGoto action_12 -action_370 (11#) = happyGoto action_13 -action_370 (12#) = happyGoto action_14 -action_370 (58#) = happyGoto action_15 -action_370 (59#) = happyGoto action_16 -action_370 (60#) = happyGoto action_17 -action_370 (61#) = happyGoto action_18 -action_370 (62#) = happyGoto action_19 -action_370 (63#) = happyGoto action_462 -action_370 (64#) = happyGoto action_21 -action_370 (72#) = happyGoto action_22 -action_370 (77#) = happyGoto action_23 -action_370 x = happyTcHack x happyFail - -action_371 (123#) = happyShift action_461 -action_371 x = happyTcHack x happyFail - -action_372 (94#) = happyShift action_460 -action_372 x = happyTcHack x happyReduce_258 - -action_373 (97#) = happyShift action_459 -action_373 x = happyTcHack x happyFail - -action_374 x = happyTcHack x happyReduce_195 - -action_375 x = happyTcHack x happyReduce_215 - -action_376 (96#) = happyShift action_106 -action_376 (98#) = happyShift action_107 -action_376 (104#) = happyShift action_108 -action_376 (110#) = happyShift action_109 -action_376 (111#) = happyShift action_110 -action_376 (114#) = happyShift action_111 -action_376 (121#) = happyShift action_112 -action_376 (170#) = happyShift action_6 -action_376 (171#) = happyShift action_48 -action_376 (172#) = happyShift action_49 -action_376 (174#) = happyShift action_51 -action_376 (8#) = happyGoto action_101 -action_376 (9#) = happyGoto action_102 -action_376 (10#) = happyGoto action_103 -action_376 (12#) = happyGoto action_104 -action_376 (67#) = happyGoto action_188 -action_376 (74#) = happyGoto action_458 -action_376 x = happyTcHack x happyReduce_205 - -action_377 x = happyTcHack x happyReduce_249 - -action_378 x = happyTcHack x happyReduce_219 - -action_379 x = happyTcHack x happyReduce_218 - -action_380 x = happyTcHack x happyReduce_251 - -action_381 x = happyTcHack x happyReduce_164 - -action_382 x = happyTcHack x happyReduce_165 - -action_383 (89#) = happyGoto action_457 -action_383 x = happyTcHack x happyReduce_262 - -action_384 (104#) = happyShift action_290 -action_384 (174#) = happyShift action_51 -action_384 (12#) = happyGoto action_287 -action_384 (36#) = happyGoto action_288 -action_384 (46#) = happyGoto action_456 -action_384 x = happyTcHack x happyReduce_113 - -action_385 (96#) = happyShift action_140 -action_385 (98#) = happyShift action_455 -action_385 (104#) = happyShift action_26 -action_385 (109#) = happyShift action_83 -action_385 (110#) = happyShift action_28 -action_385 (111#) = happyShift action_29 -action_385 (125#) = happyShift action_33 -action_385 (126#) = happyShift action_34 -action_385 (127#) = happyShift action_35 -action_385 (128#) = happyShift action_36 -action_385 (129#) = happyShift action_37 -action_385 (134#) = happyShift action_39 -action_385 (170#) = happyShift action_6 -action_385 (171#) = happyShift action_48 -action_385 (172#) = happyShift action_49 -action_385 (173#) = happyShift action_50 -action_385 (174#) = happyShift action_51 -action_385 (8#) = happyGoto action_10 -action_385 (9#) = happyGoto action_11 -action_385 (10#) = happyGoto action_12 -action_385 (11#) = happyGoto action_13 -action_385 (12#) = happyGoto action_79 -action_385 (58#) = happyGoto action_453 -action_385 (72#) = happyGoto action_22 -action_385 (88#) = happyGoto action_454 -action_385 x = happyTcHack x happyReduce_95 - -action_386 (174#) = happyShift action_51 -action_386 (12#) = happyGoto action_451 -action_386 (38#) = happyGoto action_284 -action_386 (48#) = happyGoto action_452 -action_386 x = happyTcHack x happyReduce_117 - -action_387 (174#) = happyShift action_51 -action_387 (12#) = happyGoto action_448 -action_387 (39#) = happyGoto action_449 -action_387 (40#) = happyGoto action_450 -action_387 x = happyTcHack x happyReduce_102 - -action_388 (174#) = happyShift action_51 -action_388 (12#) = happyGoto action_279 -action_388 (44#) = happyGoto action_280 -action_388 (51#) = happyGoto action_447 -action_388 x = happyTcHack x happyReduce_123 - -action_389 (174#) = happyShift action_51 -action_389 (12#) = happyGoto action_446 -action_389 x = happyTcHack x happyFail - -action_390 (96#) = happyShift action_24 -action_390 (98#) = happyShift action_25 -action_390 (104#) = happyShift action_26 -action_390 (109#) = happyShift action_27 -action_390 (110#) = happyShift action_28 -action_390 (111#) = happyShift action_29 -action_390 (114#) = happyShift action_30 -action_390 (119#) = happyShift action_31 -action_390 (124#) = happyShift action_32 -action_390 (125#) = happyShift action_33 -action_390 (126#) = happyShift action_34 -action_390 (127#) = happyShift action_35 -action_390 (128#) = happyShift action_36 -action_390 (129#) = happyShift action_37 -action_390 (131#) = happyShift action_38 -action_390 (134#) = happyShift action_39 -action_390 (137#) = happyShift action_40 -action_390 (140#) = happyShift action_41 -action_390 (145#) = happyShift action_42 -action_390 (156#) = happyShift action_43 -action_390 (157#) = happyShift action_44 -action_390 (161#) = happyShift action_45 -action_390 (162#) = happyShift action_46 -action_390 (167#) = happyShift action_47 -action_390 (170#) = happyShift action_6 -action_390 (171#) = happyShift action_48 -action_390 (172#) = happyShift action_49 -action_390 (173#) = happyShift action_50 -action_390 (174#) = happyShift action_51 -action_390 (8#) = happyGoto action_10 -action_390 (9#) = happyGoto action_11 -action_390 (10#) = happyGoto action_12 -action_390 (11#) = happyGoto action_13 -action_390 (12#) = happyGoto action_14 -action_390 (58#) = happyGoto action_15 -action_390 (59#) = happyGoto action_16 -action_390 (60#) = happyGoto action_17 -action_390 (61#) = happyGoto action_18 -action_390 (62#) = happyGoto action_19 -action_390 (63#) = happyGoto action_445 -action_390 (64#) = happyGoto action_21 -action_390 (72#) = happyGoto action_22 -action_390 (77#) = happyGoto action_23 -action_390 x = happyTcHack x happyFail - -action_391 (174#) = happyShift action_51 -action_391 (12#) = happyGoto action_87 -action_391 (37#) = happyGoto action_276 -action_391 (47#) = happyGoto action_444 -action_391 (53#) = happyGoto action_278 -action_391 x = happyTcHack x happyReduce_115 - -action_392 (96#) = happyShift action_443 -action_392 x = happyTcHack x happyFail - -action_393 (174#) = happyShift action_51 -action_393 (12#) = happyGoto action_267 -action_393 (41#) = happyGoto action_268 -action_393 (49#) = happyGoto action_442 -action_393 x = happyTcHack x happyReduce_119 - -action_394 (98#) = happyShift action_441 -action_394 (174#) = happyShift action_51 -action_394 (12#) = happyGoto action_438 -action_394 (42#) = happyGoto action_439 -action_394 (52#) = happyGoto action_440 -action_394 x = happyTcHack x happyReduce_125 - -action_395 x = happyTcHack x happyReduce_87 - -action_396 x = happyTcHack x happyReduce_86 - -action_397 (96#) = happyShift action_24 -action_397 (98#) = happyShift action_25 -action_397 (104#) = happyShift action_26 -action_397 (109#) = happyShift action_27 -action_397 (110#) = happyShift action_28 -action_397 (111#) = happyShift action_29 -action_397 (114#) = happyShift action_30 -action_397 (119#) = happyShift action_31 -action_397 (124#) = happyShift action_32 -action_397 (125#) = happyShift action_33 -action_397 (126#) = happyShift action_34 -action_397 (127#) = happyShift action_35 -action_397 (128#) = happyShift action_36 -action_397 (129#) = happyShift action_37 -action_397 (131#) = happyShift action_38 -action_397 (134#) = happyShift action_39 -action_397 (137#) = happyShift action_40 -action_397 (140#) = happyShift action_41 -action_397 (145#) = happyShift action_42 -action_397 (156#) = happyShift action_43 -action_397 (157#) = happyShift action_44 -action_397 (161#) = happyShift action_45 -action_397 (162#) = happyShift action_46 -action_397 (167#) = happyShift action_47 -action_397 (170#) = happyShift action_6 -action_397 (171#) = happyShift action_48 -action_397 (172#) = happyShift action_49 -action_397 (173#) = happyShift action_50 -action_397 (174#) = happyShift action_51 -action_397 (8#) = happyGoto action_10 -action_397 (9#) = happyGoto action_11 -action_397 (10#) = happyGoto action_12 -action_397 (11#) = happyGoto action_13 -action_397 (12#) = happyGoto action_14 -action_397 (58#) = happyGoto action_15 -action_397 (59#) = happyGoto action_16 -action_397 (60#) = happyGoto action_17 -action_397 (61#) = happyGoto action_18 -action_397 (62#) = happyGoto action_19 -action_397 (63#) = happyGoto action_437 -action_397 (64#) = happyGoto action_21 -action_397 (72#) = happyGoto action_22 -action_397 (77#) = happyGoto action_23 -action_397 x = happyTcHack x happyFail - -action_398 (104#) = happyShift action_257 -action_398 (174#) = happyShift action_51 -action_398 (12#) = happyGoto action_252 -action_398 (54#) = happyGoto action_262 -action_398 (55#) = happyGoto action_436 -action_398 x = happyTcHack x happyFail - -action_399 (104#) = happyShift action_257 -action_399 (174#) = happyShift action_51 -action_399 (12#) = happyGoto action_252 -action_399 (43#) = happyGoto action_260 -action_399 (50#) = happyGoto action_435 -action_399 (54#) = happyGoto action_262 -action_399 (55#) = happyGoto action_263 -action_399 x = happyTcHack x happyReduce_121 - -action_400 x = happyTcHack x happyReduce_94 - -action_401 (105#) = happyShift action_434 -action_401 x = happyTcHack x happyFail - -action_402 (96#) = happyShift action_24 -action_402 (98#) = happyShift action_25 -action_402 (104#) = happyShift action_26 -action_402 (109#) = happyShift action_27 -action_402 (110#) = happyShift action_28 -action_402 (111#) = happyShift action_29 -action_402 (114#) = happyShift action_30 -action_402 (119#) = happyShift action_31 -action_402 (124#) = happyShift action_32 -action_402 (125#) = happyShift action_33 -action_402 (126#) = happyShift action_34 -action_402 (127#) = happyShift action_35 -action_402 (128#) = happyShift action_36 -action_402 (129#) = happyShift action_37 -action_402 (131#) = happyShift action_38 -action_402 (134#) = happyShift action_39 -action_402 (137#) = happyShift action_40 -action_402 (140#) = happyShift action_41 -action_402 (145#) = happyShift action_42 -action_402 (156#) = happyShift action_43 -action_402 (157#) = happyShift action_44 -action_402 (161#) = happyShift action_45 -action_402 (162#) = happyShift action_46 -action_402 (167#) = happyShift action_47 -action_402 (170#) = happyShift action_6 -action_402 (171#) = happyShift action_48 -action_402 (172#) = happyShift action_49 -action_402 (173#) = happyShift action_50 -action_402 (174#) = happyShift action_51 -action_402 (8#) = happyGoto action_10 -action_402 (9#) = happyGoto action_11 -action_402 (10#) = happyGoto action_12 -action_402 (11#) = happyGoto action_13 -action_402 (12#) = happyGoto action_14 -action_402 (58#) = happyGoto action_15 -action_402 (59#) = happyGoto action_16 -action_402 (60#) = happyGoto action_17 -action_402 (61#) = happyGoto action_18 -action_402 (62#) = happyGoto action_19 -action_402 (63#) = happyGoto action_433 -action_402 (64#) = happyGoto action_21 -action_402 (72#) = happyGoto action_22 -action_402 (77#) = happyGoto action_23 -action_402 x = happyTcHack x happyFail - -action_403 (96#) = happyShift action_24 -action_403 (98#) = happyShift action_25 -action_403 (104#) = happyShift action_26 -action_403 (109#) = happyShift action_27 -action_403 (110#) = happyShift action_28 -action_403 (111#) = happyShift action_29 -action_403 (114#) = happyShift action_30 -action_403 (119#) = happyShift action_31 -action_403 (124#) = happyShift action_32 -action_403 (125#) = happyShift action_33 -action_403 (126#) = happyShift action_34 -action_403 (127#) = happyShift action_35 -action_403 (128#) = happyShift action_36 -action_403 (129#) = happyShift action_37 -action_403 (131#) = happyShift action_38 -action_403 (134#) = happyShift action_39 -action_403 (137#) = happyShift action_40 -action_403 (140#) = happyShift action_41 -action_403 (145#) = happyShift action_42 -action_403 (156#) = happyShift action_43 -action_403 (157#) = happyShift action_44 -action_403 (161#) = happyShift action_45 -action_403 (162#) = happyShift action_46 -action_403 (167#) = happyShift action_47 -action_403 (170#) = happyShift action_6 -action_403 (171#) = happyShift action_48 -action_403 (172#) = happyShift action_49 -action_403 (173#) = happyShift action_50 -action_403 (174#) = happyShift action_51 -action_403 (8#) = happyGoto action_10 -action_403 (9#) = happyGoto action_11 -action_403 (10#) = happyGoto action_12 -action_403 (11#) = happyGoto action_13 -action_403 (12#) = happyGoto action_14 -action_403 (58#) = happyGoto action_15 -action_403 (59#) = happyGoto action_16 -action_403 (60#) = happyGoto action_17 -action_403 (61#) = happyGoto action_18 -action_403 (62#) = happyGoto action_19 -action_403 (63#) = happyGoto action_432 -action_403 (64#) = happyGoto action_21 -action_403 (72#) = happyGoto action_22 -action_403 (77#) = happyGoto action_23 -action_403 x = happyTcHack x happyFail - -action_404 (95#) = happyShift action_431 -action_404 x = happyTcHack x happyFail - -action_405 (104#) = happyShift action_257 -action_405 (174#) = happyShift action_51 -action_405 (12#) = happyGoto action_252 -action_405 (34#) = happyGoto action_253 -action_405 (45#) = happyGoto action_430 -action_405 (54#) = happyGoto action_255 -action_405 (55#) = happyGoto action_256 -action_405 x = happyTcHack x happyReduce_111 - -action_406 x = happyTcHack x happyReduce_57 - -action_407 (101#) = happyShift action_429 -action_407 x = happyTcHack x happyFail - -action_408 (142#) = happyShift action_427 -action_408 (144#) = happyShift action_428 -action_408 (31#) = happyGoto action_426 -action_408 x = happyTcHack x happyReduce_62 - -action_409 x = happyTcHack x happyReduce_38 - -action_410 x = happyTcHack x happyReduce_37 - -action_411 x = happyTcHack x happyReduce_47 - -action_412 x = happyTcHack x happyReduce_46 - -action_413 (98#) = happyShift action_408 -action_413 (174#) = happyShift action_51 -action_413 (12#) = happyGoto action_406 -action_413 (27#) = happyGoto action_424 -action_413 (29#) = happyGoto action_425 -action_413 x = happyTcHack x happyReduce_52 - -action_414 (174#) = happyShift action_51 -action_414 (12#) = happyGoto action_241 -action_414 (33#) = happyGoto action_423 -action_414 x = happyTcHack x happyReduce_50 - -action_415 (96#) = happyShift action_422 -action_415 x = happyTcHack x happyFail - -action_416 (174#) = happyShift action_51 -action_416 (12#) = happyGoto action_87 -action_416 (53#) = happyGoto action_421 -action_416 x = happyTcHack x happyFail - -action_417 (104#) = happyShift action_420 -action_417 x = happyTcHack x happyFail - -action_418 (95#) = happyShift action_419 -action_418 x = happyTcHack x happyFail - -action_419 (174#) = happyShift action_51 -action_419 (12#) = happyGoto action_492 -action_419 x = happyTcHack x happyFail - -action_420 (174#) = happyShift action_51 -action_420 (12#) = happyGoto action_87 -action_420 (53#) = happyGoto action_491 -action_420 x = happyTcHack x happyFail - -action_421 (105#) = happyShift action_490 -action_421 x = happyTcHack x happyFail - -action_422 (25#) = happyGoto action_489 -action_422 x = happyTcHack x happyReduce_48 - -action_423 (169#) = happyShift action_488 -action_423 x = happyTcHack x happyFail - -action_424 (102#) = happyShift action_487 -action_424 x = happyTcHack x happyReduce_42 - -action_425 (103#) = happyShift action_486 -action_425 x = happyTcHack x happyReduce_53 - -action_426 (174#) = happyShift action_51 -action_426 (12#) = happyGoto action_485 -action_426 x = happyTcHack x happyFail - -action_427 x = happyTcHack x happyReduce_63 - -action_428 x = happyTcHack x happyReduce_64 - -action_429 (98#) = happyShift action_408 -action_429 (174#) = happyShift action_51 -action_429 (12#) = happyGoto action_406 -action_429 (29#) = happyGoto action_484 -action_429 x = happyTcHack x happyFail - -action_430 x = happyTcHack x happyReduce_112 - -action_431 (96#) = happyShift action_24 -action_431 (98#) = happyShift action_25 -action_431 (104#) = happyShift action_26 -action_431 (109#) = happyShift action_27 -action_431 (110#) = happyShift action_28 -action_431 (111#) = happyShift action_29 -action_431 (114#) = happyShift action_30 -action_431 (119#) = happyShift action_31 -action_431 (124#) = happyShift action_32 -action_431 (125#) = happyShift action_33 -action_431 (126#) = happyShift action_34 -action_431 (127#) = happyShift action_35 -action_431 (128#) = happyShift action_36 -action_431 (129#) = happyShift action_37 -action_431 (131#) = happyShift action_38 -action_431 (134#) = happyShift action_39 -action_431 (137#) = happyShift action_40 -action_431 (140#) = happyShift action_41 -action_431 (145#) = happyShift action_42 -action_431 (156#) = happyShift action_43 -action_431 (157#) = happyShift action_44 -action_431 (161#) = happyShift action_45 -action_431 (162#) = happyShift action_46 -action_431 (167#) = happyShift action_47 -action_431 (170#) = happyShift action_6 -action_431 (171#) = happyShift action_48 -action_431 (172#) = happyShift action_49 -action_431 (173#) = happyShift action_50 -action_431 (174#) = happyShift action_51 -action_431 (8#) = happyGoto action_10 -action_431 (9#) = happyGoto action_11 -action_431 (10#) = happyGoto action_12 -action_431 (11#) = happyGoto action_13 -action_431 (12#) = happyGoto action_14 -action_431 (58#) = happyGoto action_15 -action_431 (59#) = happyGoto action_16 -action_431 (60#) = happyGoto action_17 -action_431 (61#) = happyGoto action_18 -action_431 (62#) = happyGoto action_19 -action_431 (63#) = happyGoto action_483 -action_431 (64#) = happyGoto action_21 -action_431 (72#) = happyGoto action_22 -action_431 (77#) = happyGoto action_23 -action_431 x = happyTcHack x happyFail - -action_432 (95#) = happyShift action_482 -action_432 x = happyTcHack x happyReduce_71 - -action_433 x = happyTcHack x happyReduce_72 - -action_434 x = happyTcHack x happyReduce_131 - -action_435 x = happyTcHack x happyReduce_122 - -action_436 x = happyTcHack x happyReduce_133 - -action_437 x = happyTcHack x happyReduce_109 - -action_438 (89#) = happyGoto action_481 -action_438 x = happyTcHack x happyReduce_262 - -action_439 (108#) = happyShift action_480 -action_439 x = happyTcHack x happyReduce_126 - -action_440 x = happyTcHack x happyReduce_105 - -action_441 (140#) = happyShift action_479 -action_441 x = happyTcHack x happyFail - -action_442 x = happyTcHack x happyReduce_120 - -action_443 (25#) = happyGoto action_478 -action_443 x = happyTcHack x happyReduce_48 - -action_444 x = happyTcHack x happyReduce_116 - -action_445 x = happyTcHack x happyReduce_98 - -action_446 x = happyTcHack x happyReduce_110 - -action_447 x = happyTcHack x happyReduce_124 - -action_448 (107#) = happyShift action_477 -action_448 x = happyTcHack x happyReduce_100 - -action_449 (108#) = happyShift action_476 -action_449 x = happyTcHack x happyReduce_103 - -action_450 x = happyTcHack x happyReduce_99 - -action_451 (95#) = happyShift action_387 -action_451 x = happyTcHack x happyFail - -action_452 x = happyTcHack x happyReduce_118 - -action_453 x = happyTcHack x happyReduce_261 - -action_454 x = happyTcHack x happyReduce_263 - -action_455 (96#) = happyShift action_24 -action_455 (98#) = happyShift action_25 -action_455 (104#) = happyShift action_26 -action_455 (109#) = happyShift action_27 -action_455 (110#) = happyShift action_28 -action_455 (111#) = happyShift action_29 -action_455 (114#) = happyShift action_30 -action_455 (119#) = happyShift action_31 -action_455 (121#) = happyShift action_100 -action_455 (124#) = happyShift action_32 -action_455 (125#) = happyShift action_33 -action_455 (126#) = happyShift action_34 -action_455 (127#) = happyShift action_35 -action_455 (128#) = happyShift action_36 -action_455 (129#) = happyShift action_37 -action_455 (131#) = happyShift action_38 -action_455 (134#) = happyShift action_39 -action_455 (137#) = happyShift action_40 -action_455 (140#) = happyShift action_123 -action_455 (145#) = happyShift action_42 -action_455 (156#) = happyShift action_43 -action_455 (157#) = happyShift action_44 -action_455 (161#) = happyShift action_45 -action_455 (162#) = happyShift action_46 -action_455 (167#) = happyShift action_47 -action_455 (170#) = happyShift action_6 -action_455 (171#) = happyShift action_48 -action_455 (172#) = happyShift action_49 -action_455 (173#) = happyShift action_50 -action_455 (174#) = happyShift action_51 -action_455 (8#) = happyGoto action_10 -action_455 (9#) = happyGoto action_11 -action_455 (10#) = happyGoto action_12 -action_455 (11#) = happyGoto action_13 -action_455 (12#) = happyGoto action_120 -action_455 (58#) = happyGoto action_15 -action_455 (59#) = happyGoto action_16 -action_455 (60#) = happyGoto action_17 -action_455 (61#) = happyGoto action_18 -action_455 (62#) = happyGoto action_19 -action_455 (63#) = happyGoto action_121 -action_455 (64#) = happyGoto action_21 -action_455 (72#) = happyGoto action_22 -action_455 (75#) = happyGoto action_97 -action_455 (76#) = happyGoto action_475 -action_455 (77#) = happyGoto action_23 -action_455 x = happyTcHack x happyReduce_236 - -action_456 x = happyTcHack x happyReduce_114 - -action_457 (96#) = happyShift action_140 -action_457 (98#) = happyShift action_455 -action_457 (104#) = happyShift action_26 -action_457 (105#) = happyShift action_474 -action_457 (109#) = happyShift action_83 -action_457 (110#) = happyShift action_28 -action_457 (111#) = happyShift action_29 -action_457 (125#) = happyShift action_33 -action_457 (126#) = happyShift action_34 -action_457 (127#) = happyShift action_35 -action_457 (128#) = happyShift action_36 -action_457 (129#) = happyShift action_37 -action_457 (134#) = happyShift action_39 -action_457 (170#) = happyShift action_6 -action_457 (171#) = happyShift action_48 -action_457 (172#) = happyShift action_49 -action_457 (173#) = happyShift action_50 -action_457 (174#) = happyShift action_51 -action_457 (8#) = happyGoto action_10 -action_457 (9#) = happyGoto action_11 -action_457 (10#) = happyGoto action_12 -action_457 (11#) = happyGoto action_13 -action_457 (12#) = happyGoto action_79 -action_457 (58#) = happyGoto action_453 -action_457 (72#) = happyGoto action_22 -action_457 (88#) = happyGoto action_454 -action_457 x = happyTcHack x happyFail - -action_458 x = happyTcHack x happyReduce_213 - -action_459 x = happyTcHack x happyReduce_168 - -action_460 (96#) = happyShift action_24 -action_460 (98#) = happyShift action_25 -action_460 (104#) = happyShift action_26 -action_460 (109#) = happyShift action_27 -action_460 (110#) = happyShift action_28 -action_460 (111#) = happyShift action_29 -action_460 (114#) = happyShift action_30 -action_460 (119#) = happyShift action_31 -action_460 (124#) = happyShift action_32 -action_460 (125#) = happyShift action_33 -action_460 (126#) = happyShift action_34 -action_460 (127#) = happyShift action_35 -action_460 (128#) = happyShift action_36 -action_460 (129#) = happyShift action_37 -action_460 (131#) = happyShift action_38 -action_460 (134#) = happyShift action_39 -action_460 (137#) = happyShift action_40 -action_460 (140#) = happyShift action_41 -action_460 (145#) = happyShift action_42 -action_460 (156#) = happyShift action_43 -action_460 (157#) = happyShift action_44 -action_460 (161#) = happyShift action_45 -action_460 (162#) = happyShift action_46 -action_460 (167#) = happyShift action_47 -action_460 (170#) = happyShift action_6 -action_460 (171#) = happyShift action_48 -action_460 (172#) = happyShift action_49 -action_460 (173#) = happyShift action_50 -action_460 (174#) = happyShift action_51 -action_460 (8#) = happyGoto action_10 -action_460 (9#) = happyGoto action_11 -action_460 (10#) = happyGoto action_12 -action_460 (11#) = happyGoto action_13 -action_460 (12#) = happyGoto action_14 -action_460 (58#) = happyGoto action_15 -action_460 (59#) = happyGoto action_16 -action_460 (60#) = happyGoto action_17 -action_460 (61#) = happyGoto action_18 -action_460 (62#) = happyGoto action_19 -action_460 (63#) = happyGoto action_371 -action_460 (64#) = happyGoto action_21 -action_460 (72#) = happyGoto action_22 -action_460 (77#) = happyGoto action_23 -action_460 (86#) = happyGoto action_372 -action_460 (87#) = happyGoto action_473 -action_460 x = happyTcHack x happyReduce_257 - -action_461 (96#) = happyShift action_24 -action_461 (98#) = happyShift action_25 -action_461 (104#) = happyShift action_26 -action_461 (109#) = happyShift action_27 -action_461 (110#) = happyShift action_28 -action_461 (111#) = happyShift action_29 -action_461 (114#) = happyShift action_30 -action_461 (119#) = happyShift action_31 -action_461 (124#) = happyShift action_32 -action_461 (125#) = happyShift action_33 -action_461 (126#) = happyShift action_34 -action_461 (127#) = happyShift action_35 -action_461 (128#) = happyShift action_36 -action_461 (129#) = happyShift action_37 -action_461 (131#) = happyShift action_38 -action_461 (134#) = happyShift action_39 -action_461 (137#) = happyShift action_40 -action_461 (140#) = happyShift action_41 -action_461 (145#) = happyShift action_42 -action_461 (156#) = happyShift action_43 -action_461 (157#) = happyShift action_44 -action_461 (161#) = happyShift action_45 -action_461 (162#) = happyShift action_46 -action_461 (167#) = happyShift action_47 -action_461 (170#) = happyShift action_6 -action_461 (171#) = happyShift action_48 -action_461 (172#) = happyShift action_49 -action_461 (173#) = happyShift action_50 -action_461 (174#) = happyShift action_51 -action_461 (8#) = happyGoto action_10 -action_461 (9#) = happyGoto action_11 -action_461 (10#) = happyGoto action_12 -action_461 (11#) = happyGoto action_13 -action_461 (12#) = happyGoto action_14 -action_461 (58#) = happyGoto action_15 -action_461 (59#) = happyGoto action_16 -action_461 (60#) = happyGoto action_17 -action_461 (61#) = happyGoto action_18 -action_461 (62#) = happyGoto action_19 -action_461 (63#) = happyGoto action_472 -action_461 (64#) = happyGoto action_21 -action_461 (72#) = happyGoto action_22 -action_461 (77#) = happyGoto action_23 -action_461 x = happyTcHack x happyFail - -action_462 x = happyTcHack x happyReduce_136 - -action_463 x = happyTcHack x happyReduce_186 - -action_464 x = happyTcHack x happyReduce_166 - -action_465 (140#) = happyShift action_471 -action_465 x = happyTcHack x happyFail - -action_466 (169#) = happyShift action_470 -action_466 x = happyTcHack x happyFail - -action_467 (102#) = happyShift action_469 -action_467 x = happyTcHack x happyReduce_28 - -action_468 x = happyTcHack x happyReduce_67 - -action_469 (151#) = happyShift action_356 -action_469 (28#) = happyGoto action_510 -action_469 x = happyTcHack x happyReduce_55 - -action_470 (98#) = happyShift action_408 -action_470 (174#) = happyShift action_51 -action_470 (12#) = happyGoto action_406 -action_470 (27#) = happyGoto action_509 -action_470 (29#) = happyGoto action_425 -action_470 x = happyTcHack x happyReduce_52 - -action_471 x = happyTcHack x happyReduce_56 - -action_472 x = happyTcHack x happyReduce_256 - -action_473 x = happyTcHack x happyReduce_259 - -action_474 (96#) = happyShift action_508 -action_474 x = happyTcHack x happyReduce_96 - -action_475 (100#) = happyShift action_507 -action_475 x = happyTcHack x happyFail - -action_476 (174#) = happyShift action_51 -action_476 (12#) = happyGoto action_448 -action_476 (39#) = happyGoto action_449 -action_476 (40#) = happyGoto action_506 -action_476 x = happyTcHack x happyReduce_102 - -action_477 (174#) = happyShift action_51 -action_477 (12#) = happyGoto action_505 -action_477 x = happyTcHack x happyFail - -action_478 (97#) = happyShift action_504 -action_478 (132#) = happyShift action_210 -action_478 (134#) = happyShift action_211 -action_478 (135#) = happyShift action_212 -action_478 (136#) = happyShift action_213 -action_478 (138#) = happyShift action_214 -action_478 (146#) = happyShift action_215 -action_478 (147#) = happyShift action_216 -action_478 (148#) = happyShift action_217 -action_478 (149#) = happyShift action_218 -action_478 (152#) = happyShift action_219 -action_478 (154#) = happyShift action_220 -action_478 (155#) = happyShift action_221 -action_478 (156#) = happyShift action_222 -action_478 (158#) = happyShift action_223 -action_478 (163#) = happyShift action_224 -action_478 (164#) = happyShift action_225 -action_478 (166#) = happyShift action_226 -action_478 (35#) = happyGoto action_209 -action_478 x = happyTcHack x happyFail - -action_479 (174#) = happyShift action_51 -action_479 (12#) = happyGoto action_503 -action_479 x = happyTcHack x happyFail - -action_480 (174#) = happyShift action_51 -action_480 (12#) = happyGoto action_438 -action_480 (42#) = happyGoto action_439 -action_480 (52#) = happyGoto action_502 -action_480 x = happyTcHack x happyReduce_125 - -action_481 (96#) = happyShift action_140 -action_481 (98#) = happyShift action_455 -action_481 (104#) = happyShift action_26 -action_481 (109#) = happyShift action_83 -action_481 (110#) = happyShift action_28 -action_481 (111#) = happyShift action_29 -action_481 (125#) = happyShift action_33 -action_481 (126#) = happyShift action_34 -action_481 (127#) = happyShift action_35 -action_481 (128#) = happyShift action_36 -action_481 (129#) = happyShift action_37 -action_481 (134#) = happyShift action_39 -action_481 (170#) = happyShift action_6 -action_481 (171#) = happyShift action_48 -action_481 (172#) = happyShift action_49 -action_481 (173#) = happyShift action_50 -action_481 (174#) = happyShift action_51 -action_481 (8#) = happyGoto action_10 -action_481 (9#) = happyGoto action_11 -action_481 (10#) = happyGoto action_12 -action_481 (11#) = happyGoto action_13 -action_481 (12#) = happyGoto action_79 -action_481 (58#) = happyGoto action_453 -action_481 (72#) = happyGoto action_22 -action_481 (88#) = happyGoto action_454 -action_481 x = happyTcHack x happyReduce_108 - -action_482 (96#) = happyShift action_24 -action_482 (98#) = happyShift action_25 -action_482 (104#) = happyShift action_26 -action_482 (109#) = happyShift action_27 -action_482 (110#) = happyShift action_28 -action_482 (111#) = happyShift action_29 -action_482 (114#) = happyShift action_30 -action_482 (119#) = happyShift action_31 -action_482 (124#) = happyShift action_32 -action_482 (125#) = happyShift action_33 -action_482 (126#) = happyShift action_34 -action_482 (127#) = happyShift action_35 -action_482 (128#) = happyShift action_36 -action_482 (129#) = happyShift action_37 -action_482 (131#) = happyShift action_38 -action_482 (134#) = happyShift action_39 -action_482 (137#) = happyShift action_40 -action_482 (140#) = happyShift action_41 -action_482 (145#) = happyShift action_42 -action_482 (156#) = happyShift action_43 -action_482 (157#) = happyShift action_44 -action_482 (161#) = happyShift action_45 -action_482 (162#) = happyShift action_46 -action_482 (167#) = happyShift action_47 -action_482 (170#) = happyShift action_6 -action_482 (171#) = happyShift action_48 -action_482 (172#) = happyShift action_49 -action_482 (173#) = happyShift action_50 -action_482 (174#) = happyShift action_51 -action_482 (8#) = happyGoto action_10 -action_482 (9#) = happyGoto action_11 -action_482 (10#) = happyGoto action_12 -action_482 (11#) = happyGoto action_13 -action_482 (12#) = happyGoto action_14 -action_482 (58#) = happyGoto action_15 -action_482 (59#) = happyGoto action_16 -action_482 (60#) = happyGoto action_17 -action_482 (61#) = happyGoto action_18 -action_482 (62#) = happyGoto action_19 -action_482 (63#) = happyGoto action_501 -action_482 (64#) = happyGoto action_21 -action_482 (72#) = happyGoto action_22 -action_482 (77#) = happyGoto action_23 -action_482 x = happyTcHack x happyFail - -action_483 x = happyTcHack x happyReduce_73 - -action_484 x = happyTcHack x happyReduce_39 - -action_485 (95#) = happyShift action_499 -action_485 (99#) = happyShift action_500 -action_485 x = happyTcHack x happyFail - -action_486 (98#) = happyShift action_408 -action_486 (174#) = happyShift action_51 -action_486 (12#) = happyGoto action_406 -action_486 (27#) = happyGoto action_498 -action_486 (29#) = happyGoto action_425 -action_486 x = happyTcHack x happyReduce_52 - -action_487 (151#) = happyShift action_356 -action_487 (28#) = happyGoto action_497 -action_487 x = happyTcHack x happyReduce_55 - -action_488 (98#) = happyShift action_408 -action_488 (174#) = happyShift action_51 -action_488 (12#) = happyGoto action_406 -action_488 (27#) = happyGoto action_496 -action_488 (29#) = happyGoto action_425 -action_488 x = happyTcHack x happyReduce_52 - -action_489 (97#) = happyShift action_495 -action_489 (132#) = happyShift action_210 -action_489 (134#) = happyShift action_211 -action_489 (135#) = happyShift action_212 -action_489 (136#) = happyShift action_213 -action_489 (138#) = happyShift action_214 -action_489 (146#) = happyShift action_215 -action_489 (147#) = happyShift action_216 -action_489 (148#) = happyShift action_217 -action_489 (149#) = happyShift action_218 -action_489 (152#) = happyShift action_219 -action_489 (154#) = happyShift action_220 -action_489 (155#) = happyShift action_221 -action_489 (156#) = happyShift action_222 -action_489 (158#) = happyShift action_223 -action_489 (163#) = happyShift action_224 -action_489 (164#) = happyShift action_225 -action_489 (166#) = happyShift action_226 -action_489 (35#) = happyGoto action_209 -action_489 x = happyTcHack x happyFail - -action_490 x = happyTcHack x happyReduce_69 - -action_491 (105#) = happyShift action_494 -action_491 x = happyTcHack x happyFail - -action_492 (94#) = happyShift action_493 -action_492 x = happyTcHack x happyFail - -action_493 (174#) = happyShift action_51 -action_493 (12#) = happyGoto action_519 -action_493 (16#) = happyGoto action_520 -action_493 (17#) = happyGoto action_521 -action_493 x = happyTcHack x happyReduce_17 - -action_494 x = happyTcHack x happyReduce_70 - -action_495 x = happyTcHack x happyReduce_40 - -action_496 (102#) = happyShift action_518 -action_496 x = happyTcHack x happyReduce_44 - -action_497 (96#) = happyShift action_517 -action_497 x = happyTcHack x happyFail - -action_498 x = happyTcHack x happyReduce_54 - -action_499 (174#) = happyShift action_51 -action_499 (12#) = happyGoto action_516 -action_499 x = happyTcHack x happyFail - -action_500 x = happyTcHack x happyReduce_58 - -action_501 x = happyTcHack x happyReduce_74 - -action_502 x = happyTcHack x happyReduce_127 - -action_503 (99#) = happyShift action_515 -action_503 x = happyTcHack x happyFail - -action_504 (94#) = happyShift action_514 -action_504 x = happyTcHack x happyFail - -action_505 x = happyTcHack x happyReduce_101 - -action_506 x = happyTcHack x happyReduce_104 - -action_507 (96#) = happyShift action_24 -action_507 (98#) = happyShift action_25 -action_507 (104#) = happyShift action_26 -action_507 (109#) = happyShift action_27 -action_507 (110#) = happyShift action_28 -action_507 (111#) = happyShift action_29 -action_507 (114#) = happyShift action_30 -action_507 (119#) = happyShift action_31 -action_507 (124#) = happyShift action_32 -action_507 (125#) = happyShift action_33 -action_507 (126#) = happyShift action_34 -action_507 (127#) = happyShift action_35 -action_507 (128#) = happyShift action_36 -action_507 (129#) = happyShift action_37 -action_507 (131#) = happyShift action_38 -action_507 (134#) = happyShift action_39 -action_507 (137#) = happyShift action_40 -action_507 (140#) = happyShift action_41 -action_507 (145#) = happyShift action_42 -action_507 (156#) = happyShift action_43 -action_507 (157#) = happyShift action_44 -action_507 (161#) = happyShift action_45 -action_507 (162#) = happyShift action_46 -action_507 (167#) = happyShift action_47 -action_507 (170#) = happyShift action_6 -action_507 (171#) = happyShift action_48 -action_507 (172#) = happyShift action_49 -action_507 (173#) = happyShift action_50 -action_507 (174#) = happyShift action_51 -action_507 (8#) = happyGoto action_10 -action_507 (9#) = happyGoto action_11 -action_507 (10#) = happyGoto action_12 -action_507 (11#) = happyGoto action_13 -action_507 (12#) = happyGoto action_14 -action_507 (58#) = happyGoto action_15 -action_507 (59#) = happyGoto action_16 -action_507 (60#) = happyGoto action_17 -action_507 (61#) = happyGoto action_18 -action_507 (62#) = happyGoto action_19 -action_507 (63#) = happyGoto action_513 -action_507 (64#) = happyGoto action_21 -action_507 (72#) = happyGoto action_22 -action_507 (77#) = happyGoto action_23 -action_507 x = happyTcHack x happyFail - -action_508 (170#) = happyShift action_6 -action_508 (8#) = happyGoto action_512 -action_508 x = happyTcHack x happyFail - -action_509 (102#) = happyShift action_511 -action_509 x = happyTcHack x happyReduce_30 - -action_510 x = happyTcHack x happyReduce_29 - -action_511 (151#) = happyShift action_356 -action_511 (28#) = happyGoto action_530 -action_511 x = happyTcHack x happyReduce_55 - -action_512 (97#) = happyShift action_529 -action_512 x = happyTcHack x happyFail - -action_513 (99#) = happyShift action_528 -action_513 x = happyTcHack x happyFail - -action_514 x = happyTcHack x happyReduce_92 - -action_515 x = happyTcHack x happyReduce_106 - -action_516 (99#) = happyShift action_527 -action_516 x = happyTcHack x happyFail - -action_517 (25#) = happyGoto action_526 -action_517 x = happyTcHack x happyReduce_48 - -action_518 (151#) = happyShift action_356 -action_518 (28#) = happyGoto action_525 -action_518 x = happyTcHack x happyReduce_55 - -action_519 (95#) = happyShift action_524 -action_519 x = happyTcHack x happyFail - -action_520 (94#) = happyShift action_523 -action_520 x = happyTcHack x happyReduce_18 - -action_521 (97#) = happyShift action_522 -action_521 x = happyTcHack x happyFail - -action_522 x = happyTcHack x happyReduce_14 - -action_523 (174#) = happyShift action_51 -action_523 (12#) = happyGoto action_519 -action_523 (16#) = happyGoto action_520 -action_523 (17#) = happyGoto action_535 -action_523 x = happyTcHack x happyReduce_17 - -action_524 (174#) = happyShift action_51 -action_524 (12#) = happyGoto action_533 -action_524 (18#) = happyGoto action_534 -action_524 x = happyTcHack x happyFail - -action_525 (96#) = happyShift action_532 -action_525 x = happyTcHack x happyFail - -action_526 (97#) = happyShift action_531 -action_526 (132#) = happyShift action_210 -action_526 (134#) = happyShift action_211 -action_526 (135#) = happyShift action_212 -action_526 (136#) = happyShift action_213 -action_526 (138#) = happyShift action_214 -action_526 (146#) = happyShift action_215 -action_526 (147#) = happyShift action_216 -action_526 (148#) = happyShift action_217 -action_526 (149#) = happyShift action_218 -action_526 (152#) = happyShift action_219 -action_526 (154#) = happyShift action_220 -action_526 (155#) = happyShift action_221 -action_526 (156#) = happyShift action_222 -action_526 (158#) = happyShift action_223 -action_526 (163#) = happyShift action_224 -action_526 (164#) = happyShift action_225 -action_526 (166#) = happyShift action_226 -action_526 (35#) = happyGoto action_209 -action_526 x = happyTcHack x happyFail - -action_527 x = happyTcHack x happyReduce_59 - -action_528 x = happyTcHack x happyReduce_260 - -action_529 x = happyTcHack x happyReduce_97 - -action_530 x = happyTcHack x happyReduce_31 - -action_531 x = happyTcHack x happyReduce_43 - -action_532 (25#) = happyGoto action_537 -action_532 x = happyTcHack x happyReduce_48 - -action_533 (19#) = happyGoto action_536 -action_533 x = happyTcHack x happyReduce_21 - -action_534 x = happyTcHack x happyReduce_16 - -action_535 x = happyTcHack x happyReduce_19 - -action_536 (98#) = happyShift action_540 -action_536 (20#) = happyGoto action_539 -action_536 x = happyTcHack x happyReduce_20 - -action_537 (97#) = happyShift action_538 -action_537 (132#) = happyShift action_210 -action_537 (134#) = happyShift action_211 -action_537 (135#) = happyShift action_212 -action_537 (136#) = happyShift action_213 -action_537 (138#) = happyShift action_214 -action_537 (146#) = happyShift action_215 -action_537 (147#) = happyShift action_216 -action_537 (148#) = happyShift action_217 -action_537 (149#) = happyShift action_218 -action_537 (152#) = happyShift action_219 -action_537 (154#) = happyShift action_220 -action_537 (155#) = happyShift action_221 -action_537 (156#) = happyShift action_222 -action_537 (158#) = happyShift action_223 -action_537 (163#) = happyShift action_224 -action_537 (164#) = happyShift action_225 -action_537 (166#) = happyShift action_226 -action_537 (35#) = happyGoto action_209 -action_537 x = happyTcHack x happyFail - -action_538 x = happyTcHack x happyReduce_45 - -action_539 x = happyTcHack x happyReduce_22 - -action_540 (164#) = happyShift action_541 -action_540 x = happyTcHack x happyFail - -action_541 (140#) = happyShift action_542 -action_541 (153#) = happyShift action_543 -action_541 x = happyTcHack x happyFail - -action_542 (98#) = happyShift action_408 -action_542 (174#) = happyShift action_51 -action_542 (12#) = happyGoto action_406 -action_542 (29#) = happyGoto action_545 -action_542 x = happyTcHack x happyFail - -action_543 (98#) = happyShift action_408 -action_543 (174#) = happyShift action_51 -action_543 (12#) = happyGoto action_406 -action_543 (29#) = happyGoto action_544 -action_543 x = happyTcHack x happyFail - -action_544 (99#) = happyShift action_547 -action_544 x = happyTcHack x happyFail - -action_545 (99#) = happyShift action_546 -action_545 x = happyTcHack x happyFail - -action_546 x = happyTcHack x happyReduce_23 - -action_547 x = happyTcHack x happyReduce_24 - -happyReduce_5 = happySpecReduce_1 8# happyReduction_5 -happyReduction_5 (HappyTerminal (PT _ (TI happy_var_1))) - = HappyAbsSyn8 - ((read happy_var_1) :: Integer - ) -happyReduction_5 _ = notHappyAtAll - -happyReduce_6 = happySpecReduce_1 9# happyReduction_6 -happyReduction_6 (HappyTerminal (PT _ (TL happy_var_1))) - = HappyAbsSyn9 - (happy_var_1 - ) -happyReduction_6 _ = notHappyAtAll - -happyReduce_7 = happySpecReduce_1 10# happyReduction_7 -happyReduction_7 (HappyTerminal (PT _ (TD happy_var_1))) - = HappyAbsSyn10 - ((read happy_var_1) :: Double - ) -happyReduction_7 _ = notHappyAtAll - -happyReduce_8 = happySpecReduce_1 11# happyReduction_8 -happyReduction_8 (HappyTerminal (PT _ (T_LString happy_var_1))) - = HappyAbsSyn11 - (LString (happy_var_1) - ) -happyReduction_8 _ = notHappyAtAll - -happyReduce_9 = happySpecReduce_1 12# happyReduction_9 -happyReduction_9 (HappyTerminal happy_var_1) - = HappyAbsSyn12 - (PIdent (mkPosToken happy_var_1) - ) -happyReduction_9 _ = notHappyAtAll - -happyReduce_10 = happySpecReduce_1 13# happyReduction_10 -happyReduction_10 (HappyAbsSyn14 happy_var_1) - = HappyAbsSyn13 - (Gr (reverse happy_var_1) - ) -happyReduction_10 _ = notHappyAtAll - -happyReduce_11 = happySpecReduce_0 14# happyReduction_11 -happyReduction_11 = HappyAbsSyn14 - ([] - ) - -happyReduce_12 = happySpecReduce_2 14# happyReduction_12 -happyReduction_12 (HappyAbsSyn15 happy_var_2) - (HappyAbsSyn14 happy_var_1) - = HappyAbsSyn14 - (flip (:) happy_var_1 happy_var_2 - ) -happyReduction_12 _ _ = notHappyAtAll - -happyReduce_13 = happySpecReduce_2 15# happyReduction_13 -happyReduction_13 _ - (HappyAbsSyn15 happy_var_1) - = HappyAbsSyn15 - (happy_var_1 - ) -happyReduction_13 _ _ = notHappyAtAll - -happyReduce_14 = happyReduce 10# 15# happyReduction_14 -happyReduction_14 (_ `HappyStk` - (HappyAbsSyn17 happy_var_9) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_7) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn15 - (MMain happy_var_2 happy_var_7 happy_var_9 - ) `HappyStk` happyRest - -happyReduce_15 = happyReduce 4# 15# happyReduction_15 -happyReduction_15 ((HappyAbsSyn22 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn23 happy_var_2) `HappyStk` - (HappyAbsSyn30 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn15 - (MModule happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_16 = happySpecReduce_3 16# happyReduction_16 -happyReduction_16 (HappyAbsSyn18 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn16 - (ConcSpec happy_var_1 happy_var_3 - ) -happyReduction_16 _ _ _ = notHappyAtAll - -happyReduce_17 = happySpecReduce_0 17# happyReduction_17 -happyReduction_17 = HappyAbsSyn17 - ([] - ) - -happyReduce_18 = happySpecReduce_1 17# happyReduction_18 -happyReduction_18 (HappyAbsSyn16 happy_var_1) - = HappyAbsSyn17 - ((:[]) happy_var_1 - ) -happyReduction_18 _ = notHappyAtAll - -happyReduce_19 = happySpecReduce_3 17# happyReduction_19 -happyReduction_19 (HappyAbsSyn17 happy_var_3) - _ - (HappyAbsSyn16 happy_var_1) - = HappyAbsSyn17 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_19 _ _ _ = notHappyAtAll - -happyReduce_20 = happySpecReduce_2 18# happyReduction_20 -happyReduction_20 (HappyAbsSyn19 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn18 - (ConcExp happy_var_1 (reverse happy_var_2) - ) -happyReduction_20 _ _ = notHappyAtAll - -happyReduce_21 = happySpecReduce_0 19# happyReduction_21 -happyReduction_21 = HappyAbsSyn19 - ([] - ) - -happyReduce_22 = happySpecReduce_2 19# happyReduction_22 -happyReduction_22 (HappyAbsSyn20 happy_var_2) - (HappyAbsSyn19 happy_var_1) - = HappyAbsSyn19 - (flip (:) happy_var_1 happy_var_2 - ) -happyReduction_22 _ _ = notHappyAtAll - -happyReduce_23 = happyReduce 5# 20# happyReduction_23 -happyReduction_23 (_ `HappyStk` - (HappyAbsSyn29 happy_var_4) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn20 - (TransferIn happy_var_4 - ) `HappyStk` happyRest - -happyReduce_24 = happyReduce 5# 20# happyReduction_24 -happyReduction_24 (_ `HappyStk` - (HappyAbsSyn29 happy_var_4) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn20 - (TransferOut happy_var_4 - ) `HappyStk` happyRest - -happyReduce_25 = happyReduce 4# 21# happyReduction_25 -happyReduction_25 ((HappyAbsSyn22 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn23 happy_var_2) `HappyStk` - (HappyAbsSyn30 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn15 - (MModule happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_26 = happySpecReduce_2 22# happyReduction_26 -happyReduction_26 (HappyAbsSyn28 happy_var_2) - (HappyAbsSyn26 happy_var_1) - = HappyAbsSyn22 - (MBody happy_var_1 happy_var_2 [] - ) -happyReduction_26 _ _ = notHappyAtAll - -happyReduce_27 = happySpecReduce_1 22# happyReduction_27 -happyReduction_27 (HappyAbsSyn32 happy_var_1) - = HappyAbsSyn22 - (MNoBody happy_var_1 - ) -happyReduction_27 _ = notHappyAtAll - -happyReduce_28 = happySpecReduce_3 22# happyReduction_28 -happyReduction_28 (HappyAbsSyn27 happy_var_3) - _ - (HappyAbsSyn33 happy_var_1) - = HappyAbsSyn22 - (MWith happy_var_1 happy_var_3 - ) -happyReduction_28 _ _ _ = notHappyAtAll - -happyReduce_29 = happyReduce 5# 22# happyReduction_29 -happyReduction_29 ((HappyAbsSyn28 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn27 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn33 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MWithBody happy_var_1 happy_var_3 happy_var_5 [] - ) `HappyStk` happyRest - -happyReduce_30 = happyReduce 5# 22# happyReduction_30 -happyReduction_30 ((HappyAbsSyn27 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn33 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn32 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MWithE happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_31 = happyReduce 7# 22# happyReduction_31 -happyReduction_31 ((HappyAbsSyn28 happy_var_7) `HappyStk` - _ `HappyStk` - (HappyAbsSyn27 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn33 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn32 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 [] - ) `HappyStk` happyRest - -happyReduce_32 = happySpecReduce_2 22# happyReduction_32 -happyReduction_32 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn22 - (MReuse happy_var_2 - ) -happyReduction_32 _ _ = notHappyAtAll - -happyReduce_33 = happySpecReduce_2 22# happyReduction_33 -happyReduction_33 (HappyAbsSyn32 happy_var_2) - _ - = HappyAbsSyn22 - (MUnion happy_var_2 - ) -happyReduction_33 _ _ = notHappyAtAll - -happyReduce_34 = happySpecReduce_2 23# happyReduction_34 -happyReduction_34 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn23 - (MTAbstract happy_var_2 - ) -happyReduction_34 _ _ = notHappyAtAll - -happyReduce_35 = happySpecReduce_2 23# happyReduction_35 -happyReduction_35 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn23 - (MTResource happy_var_2 - ) -happyReduction_35 _ _ = notHappyAtAll - -happyReduce_36 = happySpecReduce_2 23# happyReduction_36 -happyReduction_36 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn23 - (MTInterface happy_var_2 - ) -happyReduction_36 _ _ = notHappyAtAll - -happyReduce_37 = happyReduce 4# 23# happyReduction_37 -happyReduction_37 ((HappyAbsSyn12 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn23 - (MTConcrete happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_38 = happyReduce 4# 23# happyReduction_38 -happyReduction_38 ((HappyAbsSyn12 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn23 - (MTInstance happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_39 = happyReduce 6# 23# happyReduction_39 -happyReduction_39 ((HappyAbsSyn29 happy_var_6) `HappyStk` - _ `HappyStk` - (HappyAbsSyn29 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn23 - (MTTransfer happy_var_2 happy_var_4 happy_var_6 - ) `HappyStk` happyRest - -happyReduce_40 = happyReduce 5# 24# happyReduction_40 -happyReduction_40 (_ `HappyStk` - (HappyAbsSyn25 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn28 happy_var_2) `HappyStk` - (HappyAbsSyn26 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MBody happy_var_1 happy_var_2 (reverse happy_var_4) - ) `HappyStk` happyRest - -happyReduce_41 = happySpecReduce_1 24# happyReduction_41 -happyReduction_41 (HappyAbsSyn32 happy_var_1) - = HappyAbsSyn22 - (MNoBody happy_var_1 - ) -happyReduction_41 _ = notHappyAtAll - -happyReduce_42 = happySpecReduce_3 24# happyReduction_42 -happyReduction_42 (HappyAbsSyn27 happy_var_3) - _ - (HappyAbsSyn33 happy_var_1) - = HappyAbsSyn22 - (MWith happy_var_1 happy_var_3 - ) -happyReduction_42 _ _ _ = notHappyAtAll - -happyReduce_43 = happyReduce 8# 24# happyReduction_43 -happyReduction_43 (_ `HappyStk` - (HappyAbsSyn25 happy_var_7) `HappyStk` - _ `HappyStk` - (HappyAbsSyn28 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn27 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn33 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MWithBody happy_var_1 happy_var_3 happy_var_5 (reverse happy_var_7) - ) `HappyStk` happyRest - -happyReduce_44 = happyReduce 5# 24# happyReduction_44 -happyReduction_44 ((HappyAbsSyn27 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn33 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn32 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MWithE happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_45 = happyReduce 10# 24# happyReduction_45 -happyReduction_45 (_ `HappyStk` - (HappyAbsSyn25 happy_var_9) `HappyStk` - _ `HappyStk` - (HappyAbsSyn28 happy_var_7) `HappyStk` - _ `HappyStk` - (HappyAbsSyn27 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn33 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn32 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn22 - (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 (reverse happy_var_9) - ) `HappyStk` happyRest - -happyReduce_46 = happySpecReduce_2 24# happyReduction_46 -happyReduction_46 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn22 - (MReuse happy_var_2 - ) -happyReduction_46 _ _ = notHappyAtAll - -happyReduce_47 = happySpecReduce_2 24# happyReduction_47 -happyReduction_47 (HappyAbsSyn32 happy_var_2) - _ - = HappyAbsSyn22 - (MUnion happy_var_2 - ) -happyReduction_47 _ _ = notHappyAtAll - -happyReduce_48 = happySpecReduce_0 25# happyReduction_48 -happyReduction_48 = HappyAbsSyn25 - ([] - ) - -happyReduce_49 = happySpecReduce_2 25# happyReduction_49 -happyReduction_49 (HappyAbsSyn35 happy_var_2) - (HappyAbsSyn25 happy_var_1) - = HappyAbsSyn25 - (flip (:) happy_var_1 happy_var_2 - ) -happyReduction_49 _ _ = notHappyAtAll - -happyReduce_50 = happySpecReduce_2 26# happyReduction_50 -happyReduction_50 _ - (HappyAbsSyn32 happy_var_1) - = HappyAbsSyn26 - (Ext happy_var_1 - ) -happyReduction_50 _ _ = notHappyAtAll - -happyReduce_51 = happySpecReduce_0 26# happyReduction_51 -happyReduction_51 = HappyAbsSyn26 - (NoExt - ) - -happyReduce_52 = happySpecReduce_0 27# happyReduction_52 -happyReduction_52 = HappyAbsSyn27 - ([] - ) - -happyReduce_53 = happySpecReduce_1 27# happyReduction_53 -happyReduction_53 (HappyAbsSyn29 happy_var_1) - = HappyAbsSyn27 - ((:[]) happy_var_1 - ) -happyReduction_53 _ = notHappyAtAll - -happyReduce_54 = happySpecReduce_3 27# happyReduction_54 -happyReduction_54 (HappyAbsSyn27 happy_var_3) - _ - (HappyAbsSyn29 happy_var_1) - = HappyAbsSyn27 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_54 _ _ _ = notHappyAtAll - -happyReduce_55 = happySpecReduce_0 28# happyReduction_55 -happyReduction_55 = HappyAbsSyn28 - (NoOpens - ) - -happyReduce_56 = happySpecReduce_3 28# happyReduction_56 -happyReduction_56 _ - (HappyAbsSyn27 happy_var_2) - _ - = HappyAbsSyn28 - (OpenIn happy_var_2 - ) -happyReduction_56 _ _ _ = notHappyAtAll - -happyReduce_57 = happySpecReduce_1 29# happyReduction_57 -happyReduction_57 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn29 - (OName happy_var_1 - ) -happyReduction_57 _ = notHappyAtAll - -happyReduce_58 = happyReduce 4# 29# happyReduction_58 -happyReduction_58 (_ `HappyStk` - (HappyAbsSyn12 happy_var_3) `HappyStk` - (HappyAbsSyn31 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn29 - (OQualQO happy_var_2 happy_var_3 - ) `HappyStk` happyRest - -happyReduce_59 = happyReduce 6# 29# happyReduction_59 -happyReduction_59 (_ `HappyStk` - (HappyAbsSyn12 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_3) `HappyStk` - (HappyAbsSyn31 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn29 - (OQual happy_var_2 happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_60 = happySpecReduce_0 30# happyReduction_60 -happyReduction_60 = HappyAbsSyn30 - (CMCompl - ) - -happyReduce_61 = happySpecReduce_1 30# happyReduction_61 -happyReduction_61 _ - = HappyAbsSyn30 - (CMIncompl - ) - -happyReduce_62 = happySpecReduce_0 31# happyReduction_62 -happyReduction_62 = HappyAbsSyn31 - (QOCompl - ) - -happyReduce_63 = happySpecReduce_1 31# happyReduction_63 -happyReduction_63 _ - = HappyAbsSyn31 - (QOIncompl - ) - -happyReduce_64 = happySpecReduce_1 31# happyReduction_64 -happyReduction_64 _ - = HappyAbsSyn31 - (QOInterface - ) - -happyReduce_65 = happySpecReduce_0 32# happyReduction_65 -happyReduction_65 = HappyAbsSyn32 - ([] - ) - -happyReduce_66 = happySpecReduce_1 32# happyReduction_66 -happyReduction_66 (HappyAbsSyn33 happy_var_1) - = HappyAbsSyn32 - ((:[]) happy_var_1 - ) -happyReduction_66 _ = notHappyAtAll - -happyReduce_67 = happySpecReduce_3 32# happyReduction_67 -happyReduction_67 (HappyAbsSyn32 happy_var_3) - _ - (HappyAbsSyn33 happy_var_1) - = HappyAbsSyn32 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_67 _ _ _ = notHappyAtAll - -happyReduce_68 = happySpecReduce_1 33# happyReduction_68 -happyReduction_68 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn33 - (IAll happy_var_1 - ) -happyReduction_68 _ = notHappyAtAll - -happyReduce_69 = happyReduce 4# 33# happyReduction_69 -happyReduction_69 (_ `HappyStk` - (HappyAbsSyn53 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn33 - (ISome happy_var_1 happy_var_3 - ) `HappyStk` happyRest - -happyReduce_70 = happyReduce 5# 33# happyReduction_70 -happyReduction_70 (_ `HappyStk` - (HappyAbsSyn53 happy_var_4) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn33 - (IMinus happy_var_1 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_71 = happySpecReduce_3 34# happyReduction_71 -happyReduction_71 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn55 happy_var_1) - = HappyAbsSyn34 - (DDecl happy_var_1 happy_var_3 - ) -happyReduction_71 _ _ _ = notHappyAtAll - -happyReduce_72 = happySpecReduce_3 34# happyReduction_72 -happyReduction_72 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn55 happy_var_1) - = HappyAbsSyn34 - (DDef happy_var_1 happy_var_3 - ) -happyReduction_72 _ _ _ = notHappyAtAll - -happyReduce_73 = happyReduce 4# 34# happyReduction_73 -happyReduction_73 ((HappyAbsSyn58 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn74 happy_var_2) `HappyStk` - (HappyAbsSyn54 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn34 - (DPatt happy_var_1 happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_74 = happyReduce 5# 34# happyReduction_74 -happyReduction_74 ((HappyAbsSyn58 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn55 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn34 - (DFull happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_75 = happySpecReduce_2 35# happyReduction_75 -happyReduction_75 (HappyAbsSyn46 happy_var_2) - _ - = HappyAbsSyn35 - (DefCat happy_var_2 - ) -happyReduction_75 _ _ = notHappyAtAll - -happyReduce_76 = happySpecReduce_2 35# happyReduction_76 -happyReduction_76 (HappyAbsSyn47 happy_var_2) - _ - = HappyAbsSyn35 - (DefFun happy_var_2 - ) -happyReduction_76 _ _ = notHappyAtAll - -happyReduce_77 = happySpecReduce_2 35# happyReduction_77 -happyReduction_77 (HappyAbsSyn47 happy_var_2) - _ - = HappyAbsSyn35 - (DefFunData happy_var_2 - ) -happyReduction_77 _ _ = notHappyAtAll - -happyReduce_78 = happySpecReduce_2 35# happyReduction_78 -happyReduction_78 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefDef happy_var_2 - ) -happyReduction_78 _ _ = notHappyAtAll - -happyReduce_79 = happySpecReduce_2 35# happyReduction_79 -happyReduction_79 (HappyAbsSyn48 happy_var_2) - _ - = HappyAbsSyn35 - (DefData happy_var_2 - ) -happyReduction_79 _ _ = notHappyAtAll - -happyReduce_80 = happySpecReduce_2 35# happyReduction_80 -happyReduction_80 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefTrans happy_var_2 - ) -happyReduction_80 _ _ = notHappyAtAll - -happyReduce_81 = happySpecReduce_2 35# happyReduction_81 -happyReduction_81 (HappyAbsSyn49 happy_var_2) - _ - = HappyAbsSyn35 - (DefPar happy_var_2 - ) -happyReduction_81 _ _ = notHappyAtAll - -happyReduce_82 = happySpecReduce_2 35# happyReduction_82 -happyReduction_82 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefOper happy_var_2 - ) -happyReduction_82 _ _ = notHappyAtAll - -happyReduce_83 = happySpecReduce_2 35# happyReduction_83 -happyReduction_83 (HappyAbsSyn50 happy_var_2) - _ - = HappyAbsSyn35 - (DefLincat happy_var_2 - ) -happyReduction_83 _ _ = notHappyAtAll - -happyReduce_84 = happySpecReduce_2 35# happyReduction_84 -happyReduction_84 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefLindef happy_var_2 - ) -happyReduction_84 _ _ = notHappyAtAll - -happyReduce_85 = happySpecReduce_2 35# happyReduction_85 -happyReduction_85 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefLin happy_var_2 - ) -happyReduction_85 _ _ = notHappyAtAll - -happyReduce_86 = happySpecReduce_3 35# happyReduction_86 -happyReduction_86 (HappyAbsSyn50 happy_var_3) - _ - _ - = HappyAbsSyn35 - (DefPrintCat happy_var_3 - ) -happyReduction_86 _ _ _ = notHappyAtAll - -happyReduce_87 = happySpecReduce_3 35# happyReduction_87 -happyReduction_87 (HappyAbsSyn50 happy_var_3) - _ - _ - = HappyAbsSyn35 - (DefPrintFun happy_var_3 - ) -happyReduction_87 _ _ _ = notHappyAtAll - -happyReduce_88 = happySpecReduce_2 35# happyReduction_88 -happyReduction_88 (HappyAbsSyn51 happy_var_2) - _ - = HappyAbsSyn35 - (DefFlag happy_var_2 - ) -happyReduction_88 _ _ = notHappyAtAll - -happyReduce_89 = happySpecReduce_2 35# happyReduction_89 -happyReduction_89 (HappyAbsSyn50 happy_var_2) - _ - = HappyAbsSyn35 - (DefPrintOld happy_var_2 - ) -happyReduction_89 _ _ = notHappyAtAll - -happyReduce_90 = happySpecReduce_2 35# happyReduction_90 -happyReduction_90 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefLintype happy_var_2 - ) -happyReduction_90 _ _ = notHappyAtAll - -happyReduce_91 = happySpecReduce_2 35# happyReduction_91 -happyReduction_91 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefPattern happy_var_2 - ) -happyReduction_91 _ _ = notHappyAtAll - -happyReduce_92 = happyReduce 7# 35# happyReduction_92 -happyReduction_92 (_ `HappyStk` - _ `HappyStk` - (HappyAbsSyn25 happy_var_5) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn35 - (DefPackage happy_var_2 (reverse happy_var_5) - ) `HappyStk` happyRest - -happyReduce_93 = happySpecReduce_2 35# happyReduction_93 -happyReduction_93 (HappyAbsSyn45 happy_var_2) - _ - = HappyAbsSyn35 - (DefVars happy_var_2 - ) -happyReduction_93 _ _ = notHappyAtAll - -happyReduce_94 = happySpecReduce_3 35# happyReduction_94 -happyReduction_94 _ - (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn35 - (DefTokenizer happy_var_2 - ) -happyReduction_94 _ _ _ = notHappyAtAll - -happyReduce_95 = happySpecReduce_2 36# happyReduction_95 -happyReduction_95 (HappyAbsSyn89 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn36 - (SimpleCatDef happy_var_1 (reverse happy_var_2) - ) -happyReduction_95 _ _ = notHappyAtAll - -happyReduce_96 = happyReduce 4# 36# happyReduction_96 -happyReduction_96 (_ `HappyStk` - (HappyAbsSyn89 happy_var_3) `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn36 - (ListCatDef happy_var_2 (reverse happy_var_3) - ) `HappyStk` happyRest - -happyReduce_97 = happyReduce 7# 36# happyReduction_97 -happyReduction_97 (_ `HappyStk` - (HappyAbsSyn8 happy_var_6) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn89 happy_var_3) `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn36 - (ListSizeCatDef happy_var_2 (reverse happy_var_3) happy_var_6 - ) `HappyStk` happyRest - -happyReduce_98 = happySpecReduce_3 37# happyReduction_98 -happyReduction_98 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn53 happy_var_1) - = HappyAbsSyn37 - (FunDef happy_var_1 happy_var_3 - ) -happyReduction_98 _ _ _ = notHappyAtAll - -happyReduce_99 = happySpecReduce_3 38# happyReduction_99 -happyReduction_99 (HappyAbsSyn40 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn38 - (DataDef happy_var_1 happy_var_3 - ) -happyReduction_99 _ _ _ = notHappyAtAll - -happyReduce_100 = happySpecReduce_1 39# happyReduction_100 -happyReduction_100 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn39 - (DataId happy_var_1 - ) -happyReduction_100 _ = notHappyAtAll - -happyReduce_101 = happySpecReduce_3 39# happyReduction_101 -happyReduction_101 (HappyAbsSyn12 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn39 - (DataQId happy_var_1 happy_var_3 - ) -happyReduction_101 _ _ _ = notHappyAtAll - -happyReduce_102 = happySpecReduce_0 40# happyReduction_102 -happyReduction_102 = HappyAbsSyn40 - ([] - ) - -happyReduce_103 = happySpecReduce_1 40# happyReduction_103 -happyReduction_103 (HappyAbsSyn39 happy_var_1) - = HappyAbsSyn40 - ((:[]) happy_var_1 - ) -happyReduction_103 _ = notHappyAtAll - -happyReduce_104 = happySpecReduce_3 40# happyReduction_104 -happyReduction_104 (HappyAbsSyn40 happy_var_3) - _ - (HappyAbsSyn39 happy_var_1) - = HappyAbsSyn40 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_104 _ _ _ = notHappyAtAll - -happyReduce_105 = happySpecReduce_3 41# happyReduction_105 -happyReduction_105 (HappyAbsSyn52 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn41 - (ParDefDir happy_var_1 happy_var_3 - ) -happyReduction_105 _ _ _ = notHappyAtAll - -happyReduce_106 = happyReduce 6# 41# happyReduction_106 -happyReduction_106 (_ `HappyStk` - (HappyAbsSyn12 happy_var_5) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn41 - (ParDefIndir happy_var_1 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_107 = happySpecReduce_1 41# happyReduction_107 -happyReduction_107 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn41 - (ParDefAbs happy_var_1 - ) -happyReduction_107 _ = notHappyAtAll - -happyReduce_108 = happySpecReduce_2 42# happyReduction_108 -happyReduction_108 (HappyAbsSyn89 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn42 - (ParConstr happy_var_1 (reverse happy_var_2) - ) -happyReduction_108 _ _ = notHappyAtAll - -happyReduce_109 = happySpecReduce_3 43# happyReduction_109 -happyReduction_109 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn55 happy_var_1) - = HappyAbsSyn43 - (PrintDef happy_var_1 happy_var_3 - ) -happyReduction_109 _ _ _ = notHappyAtAll - -happyReduce_110 = happySpecReduce_3 44# happyReduction_110 -happyReduction_110 (HappyAbsSyn12 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn44 - (FlagDef happy_var_1 happy_var_3 - ) -happyReduction_110 _ _ _ = notHappyAtAll - -happyReduce_111 = happySpecReduce_2 45# happyReduction_111 -happyReduction_111 _ - (HappyAbsSyn34 happy_var_1) - = HappyAbsSyn45 - ((:[]) happy_var_1 - ) -happyReduction_111 _ _ = notHappyAtAll - -happyReduce_112 = happySpecReduce_3 45# happyReduction_112 -happyReduction_112 (HappyAbsSyn45 happy_var_3) - _ - (HappyAbsSyn34 happy_var_1) - = HappyAbsSyn45 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_112 _ _ _ = notHappyAtAll - -happyReduce_113 = happySpecReduce_2 46# happyReduction_113 -happyReduction_113 _ - (HappyAbsSyn36 happy_var_1) - = HappyAbsSyn46 - ((:[]) happy_var_1 - ) -happyReduction_113 _ _ = notHappyAtAll - -happyReduce_114 = happySpecReduce_3 46# happyReduction_114 -happyReduction_114 (HappyAbsSyn46 happy_var_3) - _ - (HappyAbsSyn36 happy_var_1) - = HappyAbsSyn46 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_114 _ _ _ = notHappyAtAll - -happyReduce_115 = happySpecReduce_2 47# happyReduction_115 -happyReduction_115 _ - (HappyAbsSyn37 happy_var_1) - = HappyAbsSyn47 - ((:[]) happy_var_1 - ) -happyReduction_115 _ _ = notHappyAtAll - -happyReduce_116 = happySpecReduce_3 47# happyReduction_116 -happyReduction_116 (HappyAbsSyn47 happy_var_3) - _ - (HappyAbsSyn37 happy_var_1) - = HappyAbsSyn47 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_116 _ _ _ = notHappyAtAll - -happyReduce_117 = happySpecReduce_2 48# happyReduction_117 -happyReduction_117 _ - (HappyAbsSyn38 happy_var_1) - = HappyAbsSyn48 - ((:[]) happy_var_1 - ) -happyReduction_117 _ _ = notHappyAtAll - -happyReduce_118 = happySpecReduce_3 48# happyReduction_118 -happyReduction_118 (HappyAbsSyn48 happy_var_3) - _ - (HappyAbsSyn38 happy_var_1) - = HappyAbsSyn48 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_118 _ _ _ = notHappyAtAll - -happyReduce_119 = happySpecReduce_2 49# happyReduction_119 -happyReduction_119 _ - (HappyAbsSyn41 happy_var_1) - = HappyAbsSyn49 - ((:[]) happy_var_1 - ) -happyReduction_119 _ _ = notHappyAtAll - -happyReduce_120 = happySpecReduce_3 49# happyReduction_120 -happyReduction_120 (HappyAbsSyn49 happy_var_3) - _ - (HappyAbsSyn41 happy_var_1) - = HappyAbsSyn49 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_120 _ _ _ = notHappyAtAll - -happyReduce_121 = happySpecReduce_2 50# happyReduction_121 -happyReduction_121 _ - (HappyAbsSyn43 happy_var_1) - = HappyAbsSyn50 - ((:[]) happy_var_1 - ) -happyReduction_121 _ _ = notHappyAtAll - -happyReduce_122 = happySpecReduce_3 50# happyReduction_122 -happyReduction_122 (HappyAbsSyn50 happy_var_3) - _ - (HappyAbsSyn43 happy_var_1) - = HappyAbsSyn50 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_122 _ _ _ = notHappyAtAll - -happyReduce_123 = happySpecReduce_2 51# happyReduction_123 -happyReduction_123 _ - (HappyAbsSyn44 happy_var_1) - = HappyAbsSyn51 - ((:[]) happy_var_1 - ) -happyReduction_123 _ _ = notHappyAtAll - -happyReduce_124 = happySpecReduce_3 51# happyReduction_124 -happyReduction_124 (HappyAbsSyn51 happy_var_3) - _ - (HappyAbsSyn44 happy_var_1) - = HappyAbsSyn51 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_124 _ _ _ = notHappyAtAll - -happyReduce_125 = happySpecReduce_0 52# happyReduction_125 -happyReduction_125 = HappyAbsSyn52 - ([] - ) - -happyReduce_126 = happySpecReduce_1 52# happyReduction_126 -happyReduction_126 (HappyAbsSyn42 happy_var_1) - = HappyAbsSyn52 - ((:[]) happy_var_1 - ) -happyReduction_126 _ = notHappyAtAll - -happyReduce_127 = happySpecReduce_3 52# happyReduction_127 -happyReduction_127 (HappyAbsSyn52 happy_var_3) - _ - (HappyAbsSyn42 happy_var_1) - = HappyAbsSyn52 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_127 _ _ _ = notHappyAtAll - -happyReduce_128 = happySpecReduce_1 53# happyReduction_128 -happyReduction_128 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn53 - ((:[]) happy_var_1 - ) -happyReduction_128 _ = notHappyAtAll - -happyReduce_129 = happySpecReduce_3 53# happyReduction_129 -happyReduction_129 (HappyAbsSyn53 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn53 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_129 _ _ _ = notHappyAtAll - -happyReduce_130 = happySpecReduce_1 54# happyReduction_130 -happyReduction_130 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn54 - (IdentName happy_var_1 - ) -happyReduction_130 _ = notHappyAtAll - -happyReduce_131 = happySpecReduce_3 54# happyReduction_131 -happyReduction_131 _ - (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn54 - (ListName happy_var_2 - ) -happyReduction_131 _ _ _ = notHappyAtAll - -happyReduce_132 = happySpecReduce_1 55# happyReduction_132 -happyReduction_132 (HappyAbsSyn54 happy_var_1) - = HappyAbsSyn55 - ((:[]) happy_var_1 - ) -happyReduction_132 _ = notHappyAtAll - -happyReduce_133 = happySpecReduce_3 55# happyReduction_133 -happyReduction_133 (HappyAbsSyn55 happy_var_3) - _ - (HappyAbsSyn54 happy_var_1) - = HappyAbsSyn55 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_133 _ _ _ = notHappyAtAll - -happyReduce_134 = happySpecReduce_3 56# happyReduction_134 -happyReduction_134 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn53 happy_var_1) - = HappyAbsSyn56 - (LDDecl happy_var_1 happy_var_3 - ) -happyReduction_134 _ _ _ = notHappyAtAll - -happyReduce_135 = happySpecReduce_3 56# happyReduction_135 -happyReduction_135 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn53 happy_var_1) - = HappyAbsSyn56 - (LDDef happy_var_1 happy_var_3 - ) -happyReduction_135 _ _ _ = notHappyAtAll - -happyReduce_136 = happyReduce 5# 56# happyReduction_136 -happyReduction_136 ((HappyAbsSyn58 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn53 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn56 - (LDFull happy_var_1 happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_137 = happySpecReduce_0 57# happyReduction_137 -happyReduction_137 = HappyAbsSyn57 - ([] - ) - -happyReduce_138 = happySpecReduce_1 57# happyReduction_138 -happyReduction_138 (HappyAbsSyn56 happy_var_1) - = HappyAbsSyn57 - ((:[]) happy_var_1 - ) -happyReduction_138 _ = notHappyAtAll - -happyReduce_139 = happySpecReduce_3 57# happyReduction_139 -happyReduction_139 (HappyAbsSyn57 happy_var_3) - _ - (HappyAbsSyn56 happy_var_1) - = HappyAbsSyn57 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_139 _ _ _ = notHappyAtAll - -happyReduce_140 = happySpecReduce_1 58# happyReduction_140 -happyReduction_140 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn58 - (EIdent happy_var_1 - ) -happyReduction_140 _ = notHappyAtAll - -happyReduce_141 = happySpecReduce_3 58# happyReduction_141 -happyReduction_141 _ - (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn58 - (EConstr happy_var_2 - ) -happyReduction_141 _ _ _ = notHappyAtAll - -happyReduce_142 = happySpecReduce_3 58# happyReduction_142 -happyReduction_142 _ - (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn58 - (ECons happy_var_2 - ) -happyReduction_142 _ _ _ = notHappyAtAll - -happyReduce_143 = happySpecReduce_1 58# happyReduction_143 -happyReduction_143 (HappyAbsSyn72 happy_var_1) - = HappyAbsSyn58 - (ESort happy_var_1 - ) -happyReduction_143 _ = notHappyAtAll - -happyReduce_144 = happySpecReduce_1 58# happyReduction_144 -happyReduction_144 (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn58 - (EString happy_var_1 - ) -happyReduction_144 _ = notHappyAtAll - -happyReduce_145 = happySpecReduce_1 58# happyReduction_145 -happyReduction_145 (HappyAbsSyn8 happy_var_1) - = HappyAbsSyn58 - (EInt happy_var_1 - ) -happyReduction_145 _ = notHappyAtAll - -happyReduce_146 = happySpecReduce_1 58# happyReduction_146 -happyReduction_146 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn58 - (EFloat happy_var_1 - ) -happyReduction_146 _ = notHappyAtAll - -happyReduce_147 = happySpecReduce_1 58# happyReduction_147 -happyReduction_147 _ - = HappyAbsSyn58 - (EMeta - ) - -happyReduce_148 = happySpecReduce_2 58# happyReduction_148 -happyReduction_148 _ - _ - = HappyAbsSyn58 - (EEmpty - ) - -happyReduce_149 = happySpecReduce_1 58# happyReduction_149 -happyReduction_149 _ - = HappyAbsSyn58 - (EData - ) - -happyReduce_150 = happyReduce 4# 58# happyReduction_150 -happyReduction_150 (_ `HappyStk` - (HappyAbsSyn66 happy_var_3) `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EList happy_var_2 happy_var_3 - ) `HappyStk` happyRest - -happyReduce_151 = happySpecReduce_3 58# happyReduction_151 -happyReduction_151 _ - (HappyAbsSyn9 happy_var_2) - _ - = HappyAbsSyn58 - (EStrings happy_var_2 - ) -happyReduction_151 _ _ _ = notHappyAtAll - -happyReduce_152 = happySpecReduce_3 58# happyReduction_152 -happyReduction_152 _ - (HappyAbsSyn57 happy_var_2) - _ - = HappyAbsSyn58 - (ERecord happy_var_2 - ) -happyReduction_152 _ _ _ = notHappyAtAll - -happyReduce_153 = happySpecReduce_3 58# happyReduction_153 -happyReduction_153 _ - (HappyAbsSyn80 happy_var_2) - _ - = HappyAbsSyn58 - (ETuple happy_var_2 - ) -happyReduction_153 _ _ _ = notHappyAtAll - -happyReduce_154 = happyReduce 4# 58# happyReduction_154 -happyReduction_154 (_ `HappyStk` - (HappyAbsSyn12 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EIndir happy_var_3 - ) `HappyStk` happyRest - -happyReduce_155 = happyReduce 5# 58# happyReduction_155 -happyReduction_155 (_ `HappyStk` - (HappyAbsSyn58 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ETyped happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_156 = happySpecReduce_3 58# happyReduction_156 -happyReduction_156 _ - (HappyAbsSyn58 happy_var_2) - _ - = HappyAbsSyn58 - (happy_var_2 - ) -happyReduction_156 _ _ _ = notHappyAtAll - -happyReduce_157 = happySpecReduce_1 58# happyReduction_157 -happyReduction_157 (HappyAbsSyn11 happy_var_1) - = HappyAbsSyn58 - (ELString happy_var_1 - ) -happyReduction_157 _ = notHappyAtAll - -happyReduce_158 = happySpecReduce_3 59# happyReduction_158 -happyReduction_158 (HappyAbsSyn71 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (EProj happy_var_1 happy_var_3 - ) -happyReduction_158 _ _ _ = notHappyAtAll - -happyReduce_159 = happyReduce 5# 59# happyReduction_159 -happyReduction_159 (_ `HappyStk` - (HappyAbsSyn12 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EQConstr happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_160 = happyReduce 4# 59# happyReduction_160 -happyReduction_160 ((HappyAbsSyn12 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EQCons happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_161 = happySpecReduce_1 59# happyReduction_161 -happyReduction_161 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (happy_var_1 - ) -happyReduction_161 _ = notHappyAtAll - -happyReduce_162 = happySpecReduce_2 60# happyReduction_162 -happyReduction_162 (HappyAbsSyn58 happy_var_2) - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (EApp happy_var_1 happy_var_2 - ) -happyReduction_162 _ _ = notHappyAtAll - -happyReduce_163 = happyReduce 4# 60# happyReduction_163 -happyReduction_163 (_ `HappyStk` - (HappyAbsSyn83 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ETable happy_var_3 - ) `HappyStk` happyRest - -happyReduce_164 = happyReduce 5# 60# happyReduction_164 -happyReduction_164 (_ `HappyStk` - (HappyAbsSyn83 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ETTable happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_165 = happyReduce 5# 60# happyReduction_165 -happyReduction_165 (_ `HappyStk` - (HappyAbsSyn65 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EVTable happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_166 = happyReduce 6# 60# happyReduction_166 -happyReduction_166 (_ `HappyStk` - (HappyAbsSyn83 happy_var_5) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ECase happy_var_2 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_167 = happyReduce 4# 60# happyReduction_167 -happyReduction_167 (_ `HappyStk` - (HappyAbsSyn65 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EVariants happy_var_3 - ) `HappyStk` happyRest - -happyReduce_168 = happyReduce 6# 60# happyReduction_168 -happyReduction_168 (_ `HappyStk` - (HappyAbsSyn87 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EPre happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_169 = happyReduce 4# 60# happyReduction_169 -happyReduction_169 (_ `HappyStk` - (HappyAbsSyn65 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EStrs happy_var_3 - ) `HappyStk` happyRest - -happyReduce_170 = happySpecReduce_3 60# happyReduction_170 -happyReduction_170 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn58 - (EConAt happy_var_1 happy_var_3 - ) -happyReduction_170 _ _ _ = notHappyAtAll - -happyReduce_171 = happySpecReduce_2 60# happyReduction_171 -happyReduction_171 (HappyAbsSyn67 happy_var_2) - _ - = HappyAbsSyn58 - (EPatt happy_var_2 - ) -happyReduction_171 _ _ = notHappyAtAll - -happyReduce_172 = happySpecReduce_2 60# happyReduction_172 -happyReduction_172 (HappyAbsSyn58 happy_var_2) - _ - = HappyAbsSyn58 - (EPattType happy_var_2 - ) -happyReduction_172 _ _ = notHappyAtAll - -happyReduce_173 = happySpecReduce_1 60# happyReduction_173 -happyReduction_173 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (happy_var_1 - ) -happyReduction_173 _ = notHappyAtAll - -happyReduce_174 = happySpecReduce_2 60# happyReduction_174 -happyReduction_174 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn58 - (ELin happy_var_2 - ) -happyReduction_174 _ _ = notHappyAtAll - -happyReduce_175 = happySpecReduce_3 61# happyReduction_175 -happyReduction_175 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (ESelect happy_var_1 happy_var_3 - ) -happyReduction_175 _ _ _ = notHappyAtAll - -happyReduce_176 = happySpecReduce_3 61# happyReduction_176 -happyReduction_176 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (ETupTyp happy_var_1 happy_var_3 - ) -happyReduction_176 _ _ _ = notHappyAtAll - -happyReduce_177 = happySpecReduce_3 61# happyReduction_177 -happyReduction_177 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (EExtend happy_var_1 happy_var_3 - ) -happyReduction_177 _ _ _ = notHappyAtAll - -happyReduce_178 = happySpecReduce_1 61# happyReduction_178 -happyReduction_178 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (happy_var_1 - ) -happyReduction_178 _ = notHappyAtAll - -happyReduce_179 = happySpecReduce_3 62# happyReduction_179 -happyReduction_179 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (EGlue happy_var_1 happy_var_3 - ) -happyReduction_179 _ _ _ = notHappyAtAll - -happyReduce_180 = happySpecReduce_1 62# happyReduction_180 -happyReduction_180 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (happy_var_1 - ) -happyReduction_180 _ = notHappyAtAll - -happyReduce_181 = happySpecReduce_3 63# happyReduction_181 -happyReduction_181 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (EConcat happy_var_1 happy_var_3 - ) -happyReduction_181 _ _ _ = notHappyAtAll - -happyReduce_182 = happyReduce 4# 63# happyReduction_182 -happyReduction_182 ((HappyAbsSyn58 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn76 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EAbstr happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_183 = happyReduce 5# 63# happyReduction_183 -happyReduction_183 ((HappyAbsSyn58 happy_var_5) `HappyStk` - _ `HappyStk` - (HappyAbsSyn76 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ECTable happy_var_3 happy_var_5 - ) `HappyStk` happyRest - -happyReduce_184 = happySpecReduce_3 63# happyReduction_184 -happyReduction_184 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn77 happy_var_1) - = HappyAbsSyn58 - (EProd happy_var_1 happy_var_3 - ) -happyReduction_184 _ _ _ = notHappyAtAll - -happyReduce_185 = happySpecReduce_3 63# happyReduction_185 -happyReduction_185 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (ETType happy_var_1 happy_var_3 - ) -happyReduction_185 _ _ _ = notHappyAtAll - -happyReduce_186 = happyReduce 6# 63# happyReduction_186 -happyReduction_186 ((HappyAbsSyn58 happy_var_6) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn57 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ELet happy_var_3 happy_var_6 - ) `HappyStk` happyRest - -happyReduce_187 = happyReduce 4# 63# happyReduction_187 -happyReduction_187 ((HappyAbsSyn58 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn57 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (ELetb happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_188 = happyReduce 5# 63# happyReduction_188 -happyReduction_188 (_ `HappyStk` - (HappyAbsSyn57 happy_var_4) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyAbsSyn58 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn58 - (EWhere happy_var_1 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_189 = happyReduce 4# 63# happyReduction_189 -happyReduction_189 (_ `HappyStk` - (HappyAbsSyn85 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn58 - (EEqs happy_var_3 - ) `HappyStk` happyRest - -happyReduce_190 = happySpecReduce_3 63# happyReduction_190 -happyReduction_190 (HappyAbsSyn9 happy_var_3) - (HappyAbsSyn58 happy_var_2) - _ - = HappyAbsSyn58 - (EExample happy_var_2 happy_var_3 - ) -happyReduction_190 _ _ _ = notHappyAtAll - -happyReduce_191 = happySpecReduce_1 63# happyReduction_191 -happyReduction_191 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (happy_var_1 - ) -happyReduction_191 _ = notHappyAtAll - -happyReduce_192 = happySpecReduce_1 64# happyReduction_192 -happyReduction_192 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn58 - (happy_var_1 - ) -happyReduction_192 _ = notHappyAtAll - -happyReduce_193 = happySpecReduce_0 65# happyReduction_193 -happyReduction_193 = HappyAbsSyn65 - ([] - ) - -happyReduce_194 = happySpecReduce_1 65# happyReduction_194 -happyReduction_194 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn65 - ((:[]) happy_var_1 - ) -happyReduction_194 _ = notHappyAtAll - -happyReduce_195 = happySpecReduce_3 65# happyReduction_195 -happyReduction_195 (HappyAbsSyn65 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn65 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_195 _ _ _ = notHappyAtAll - -happyReduce_196 = happySpecReduce_0 66# happyReduction_196 -happyReduction_196 = HappyAbsSyn66 - (NilExp - ) - -happyReduce_197 = happySpecReduce_2 66# happyReduction_197 -happyReduction_197 (HappyAbsSyn66 happy_var_2) - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn66 - (ConsExp happy_var_1 happy_var_2 - ) -happyReduction_197 _ _ = notHappyAtAll - -happyReduce_198 = happySpecReduce_1 67# happyReduction_198 -happyReduction_198 _ - = HappyAbsSyn67 - (PChar - ) - -happyReduce_199 = happySpecReduce_3 67# happyReduction_199 -happyReduction_199 _ - (HappyAbsSyn9 happy_var_2) - _ - = HappyAbsSyn67 - (PChars happy_var_2 - ) -happyReduction_199 _ _ _ = notHappyAtAll - -happyReduce_200 = happySpecReduce_2 67# happyReduction_200 -happyReduction_200 (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn67 - (PMacro happy_var_2 - ) -happyReduction_200 _ _ = notHappyAtAll - -happyReduce_201 = happyReduce 4# 67# happyReduction_201 -happyReduction_201 ((HappyAbsSyn12 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn67 - (PM happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_202 = happySpecReduce_1 67# happyReduction_202 -happyReduction_202 _ - = HappyAbsSyn67 - (PW - ) - -happyReduce_203 = happySpecReduce_1 67# happyReduction_203 -happyReduction_203 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn67 - (PV happy_var_1 - ) -happyReduction_203 _ = notHappyAtAll - -happyReduce_204 = happySpecReduce_3 67# happyReduction_204 -happyReduction_204 _ - (HappyAbsSyn12 happy_var_2) - _ - = HappyAbsSyn67 - (PCon happy_var_2 - ) -happyReduction_204 _ _ _ = notHappyAtAll - -happyReduce_205 = happySpecReduce_3 67# happyReduction_205 -happyReduction_205 (HappyAbsSyn12 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn67 - (PQ happy_var_1 happy_var_3 - ) -happyReduction_205 _ _ _ = notHappyAtAll - -happyReduce_206 = happySpecReduce_1 67# happyReduction_206 -happyReduction_206 (HappyAbsSyn8 happy_var_1) - = HappyAbsSyn67 - (PInt happy_var_1 - ) -happyReduction_206 _ = notHappyAtAll - -happyReduce_207 = happySpecReduce_1 67# happyReduction_207 -happyReduction_207 (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn67 - (PFloat happy_var_1 - ) -happyReduction_207 _ = notHappyAtAll - -happyReduce_208 = happySpecReduce_1 67# happyReduction_208 -happyReduction_208 (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn67 - (PStr happy_var_1 - ) -happyReduction_208 _ = notHappyAtAll - -happyReduce_209 = happySpecReduce_3 67# happyReduction_209 -happyReduction_209 _ - (HappyAbsSyn73 happy_var_2) - _ - = HappyAbsSyn67 - (PR happy_var_2 - ) -happyReduction_209 _ _ _ = notHappyAtAll - -happyReduce_210 = happySpecReduce_3 67# happyReduction_210 -happyReduction_210 _ - (HappyAbsSyn81 happy_var_2) - _ - = HappyAbsSyn67 - (PTup happy_var_2 - ) -happyReduction_210 _ _ _ = notHappyAtAll - -happyReduce_211 = happySpecReduce_3 67# happyReduction_211 -happyReduction_211 _ - (HappyAbsSyn67 happy_var_2) - _ - = HappyAbsSyn67 - (happy_var_2 - ) -happyReduction_211 _ _ _ = notHappyAtAll - -happyReduce_212 = happySpecReduce_2 68# happyReduction_212 -happyReduction_212 (HappyAbsSyn74 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn67 - (PC happy_var_1 happy_var_2 - ) -happyReduction_212 _ _ = notHappyAtAll - -happyReduce_213 = happyReduce 4# 68# happyReduction_213 -happyReduction_213 ((HappyAbsSyn74 happy_var_4) `HappyStk` - (HappyAbsSyn12 happy_var_3) `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_1) `HappyStk` - happyRest) - = HappyAbsSyn67 - (PQC happy_var_1 happy_var_3 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_214 = happySpecReduce_2 68# happyReduction_214 -happyReduction_214 _ - (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn67 - (PRep happy_var_1 - ) -happyReduction_214 _ _ = notHappyAtAll - -happyReduce_215 = happySpecReduce_3 68# happyReduction_215 -happyReduction_215 (HappyAbsSyn67 happy_var_3) - _ - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn67 - (PAs happy_var_1 happy_var_3 - ) -happyReduction_215 _ _ _ = notHappyAtAll - -happyReduce_216 = happySpecReduce_2 68# happyReduction_216 -happyReduction_216 (HappyAbsSyn67 happy_var_2) - _ - = HappyAbsSyn67 - (PNeg happy_var_2 - ) -happyReduction_216 _ _ = notHappyAtAll - -happyReduce_217 = happySpecReduce_1 68# happyReduction_217 -happyReduction_217 (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn67 - (happy_var_1 - ) -happyReduction_217 _ = notHappyAtAll - -happyReduce_218 = happySpecReduce_3 69# happyReduction_218 -happyReduction_218 (HappyAbsSyn67 happy_var_3) - _ - (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn67 - (PDisj happy_var_1 happy_var_3 - ) -happyReduction_218 _ _ _ = notHappyAtAll - -happyReduce_219 = happySpecReduce_3 69# happyReduction_219 -happyReduction_219 (HappyAbsSyn67 happy_var_3) - _ - (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn67 - (PSeq happy_var_1 happy_var_3 - ) -happyReduction_219 _ _ _ = notHappyAtAll - -happyReduce_220 = happySpecReduce_1 69# happyReduction_220 -happyReduction_220 (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn67 - (happy_var_1 - ) -happyReduction_220 _ = notHappyAtAll - -happyReduce_221 = happySpecReduce_3 70# happyReduction_221 -happyReduction_221 (HappyAbsSyn67 happy_var_3) - _ - (HappyAbsSyn53 happy_var_1) - = HappyAbsSyn70 - (PA happy_var_1 happy_var_3 - ) -happyReduction_221 _ _ _ = notHappyAtAll - -happyReduce_222 = happySpecReduce_1 71# happyReduction_222 -happyReduction_222 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn71 - (LIdent happy_var_1 - ) -happyReduction_222 _ = notHappyAtAll - -happyReduce_223 = happySpecReduce_2 71# happyReduction_223 -happyReduction_223 (HappyAbsSyn8 happy_var_2) - _ - = HappyAbsSyn71 - (LVar happy_var_2 - ) -happyReduction_223 _ _ = notHappyAtAll - -happyReduce_224 = happySpecReduce_1 72# happyReduction_224 -happyReduction_224 _ - = HappyAbsSyn72 - (Sort_Type - ) - -happyReduce_225 = happySpecReduce_1 72# happyReduction_225 -happyReduction_225 _ - = HappyAbsSyn72 - (Sort_PType - ) - -happyReduce_226 = happySpecReduce_1 72# happyReduction_226 -happyReduction_226 _ - = HappyAbsSyn72 - (Sort_Tok - ) - -happyReduce_227 = happySpecReduce_1 72# happyReduction_227 -happyReduction_227 _ - = HappyAbsSyn72 - (Sort_Str - ) - -happyReduce_228 = happySpecReduce_1 72# happyReduction_228 -happyReduction_228 _ - = HappyAbsSyn72 - (Sort_Strs - ) - -happyReduce_229 = happySpecReduce_0 73# happyReduction_229 -happyReduction_229 = HappyAbsSyn73 - ([] - ) - -happyReduce_230 = happySpecReduce_1 73# happyReduction_230 -happyReduction_230 (HappyAbsSyn70 happy_var_1) - = HappyAbsSyn73 - ((:[]) happy_var_1 - ) -happyReduction_230 _ = notHappyAtAll - -happyReduce_231 = happySpecReduce_3 73# happyReduction_231 -happyReduction_231 (HappyAbsSyn73 happy_var_3) - _ - (HappyAbsSyn70 happy_var_1) - = HappyAbsSyn73 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_231 _ _ _ = notHappyAtAll - -happyReduce_232 = happySpecReduce_1 74# happyReduction_232 -happyReduction_232 (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn74 - ((:[]) happy_var_1 - ) -happyReduction_232 _ = notHappyAtAll - -happyReduce_233 = happySpecReduce_2 74# happyReduction_233 -happyReduction_233 (HappyAbsSyn74 happy_var_2) - (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn74 - ((:) happy_var_1 happy_var_2 - ) -happyReduction_233 _ _ = notHappyAtAll - -happyReduce_234 = happySpecReduce_1 75# happyReduction_234 -happyReduction_234 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn75 - (BIdent happy_var_1 - ) -happyReduction_234 _ = notHappyAtAll - -happyReduce_235 = happySpecReduce_1 75# happyReduction_235 -happyReduction_235 _ - = HappyAbsSyn75 - (BWild - ) - -happyReduce_236 = happySpecReduce_0 76# happyReduction_236 -happyReduction_236 = HappyAbsSyn76 - ([] - ) - -happyReduce_237 = happySpecReduce_1 76# happyReduction_237 -happyReduction_237 (HappyAbsSyn75 happy_var_1) - = HappyAbsSyn76 - ((:[]) happy_var_1 - ) -happyReduction_237 _ = notHappyAtAll - -happyReduce_238 = happySpecReduce_3 76# happyReduction_238 -happyReduction_238 (HappyAbsSyn76 happy_var_3) - _ - (HappyAbsSyn75 happy_var_1) - = HappyAbsSyn76 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_238 _ _ _ = notHappyAtAll - -happyReduce_239 = happyReduce 5# 77# happyReduction_239 -happyReduction_239 (_ `HappyStk` - (HappyAbsSyn58 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn76 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn77 - (DDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_240 = happySpecReduce_1 77# happyReduction_240 -happyReduction_240 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn77 - (DExp happy_var_1 - ) -happyReduction_240 _ = notHappyAtAll - -happyReduce_241 = happySpecReduce_1 78# happyReduction_241 -happyReduction_241 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn78 - (TComp happy_var_1 - ) -happyReduction_241 _ = notHappyAtAll - -happyReduce_242 = happySpecReduce_1 79# happyReduction_242 -happyReduction_242 (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn79 - (PTComp happy_var_1 - ) -happyReduction_242 _ = notHappyAtAll - -happyReduce_243 = happySpecReduce_0 80# happyReduction_243 -happyReduction_243 = HappyAbsSyn80 - ([] - ) - -happyReduce_244 = happySpecReduce_1 80# happyReduction_244 -happyReduction_244 (HappyAbsSyn78 happy_var_1) - = HappyAbsSyn80 - ((:[]) happy_var_1 - ) -happyReduction_244 _ = notHappyAtAll - -happyReduce_245 = happySpecReduce_3 80# happyReduction_245 -happyReduction_245 (HappyAbsSyn80 happy_var_3) - _ - (HappyAbsSyn78 happy_var_1) - = HappyAbsSyn80 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_245 _ _ _ = notHappyAtAll - -happyReduce_246 = happySpecReduce_0 81# happyReduction_246 -happyReduction_246 = HappyAbsSyn81 - ([] - ) - -happyReduce_247 = happySpecReduce_1 81# happyReduction_247 -happyReduction_247 (HappyAbsSyn79 happy_var_1) - = HappyAbsSyn81 - ((:[]) happy_var_1 - ) -happyReduction_247 _ = notHappyAtAll - -happyReduce_248 = happySpecReduce_3 81# happyReduction_248 -happyReduction_248 (HappyAbsSyn81 happy_var_3) - _ - (HappyAbsSyn79 happy_var_1) - = HappyAbsSyn81 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_248 _ _ _ = notHappyAtAll - -happyReduce_249 = happySpecReduce_3 82# happyReduction_249 -happyReduction_249 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn67 happy_var_1) - = HappyAbsSyn82 - (Case happy_var_1 happy_var_3 - ) -happyReduction_249 _ _ _ = notHappyAtAll - -happyReduce_250 = happySpecReduce_1 83# happyReduction_250 -happyReduction_250 (HappyAbsSyn82 happy_var_1) - = HappyAbsSyn83 - ((:[]) happy_var_1 - ) -happyReduction_250 _ = notHappyAtAll - -happyReduce_251 = happySpecReduce_3 83# happyReduction_251 -happyReduction_251 (HappyAbsSyn83 happy_var_3) - _ - (HappyAbsSyn82 happy_var_1) - = HappyAbsSyn83 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_251 _ _ _ = notHappyAtAll - -happyReduce_252 = happySpecReduce_3 84# happyReduction_252 -happyReduction_252 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn74 happy_var_1) - = HappyAbsSyn84 - (Equ happy_var_1 happy_var_3 - ) -happyReduction_252 _ _ _ = notHappyAtAll - -happyReduce_253 = happySpecReduce_0 85# happyReduction_253 -happyReduction_253 = HappyAbsSyn85 - ([] - ) - -happyReduce_254 = happySpecReduce_1 85# happyReduction_254 -happyReduction_254 (HappyAbsSyn84 happy_var_1) - = HappyAbsSyn85 - ((:[]) happy_var_1 - ) -happyReduction_254 _ = notHappyAtAll - -happyReduce_255 = happySpecReduce_3 85# happyReduction_255 -happyReduction_255 (HappyAbsSyn85 happy_var_3) - _ - (HappyAbsSyn84 happy_var_1) - = HappyAbsSyn85 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_255 _ _ _ = notHappyAtAll - -happyReduce_256 = happySpecReduce_3 86# happyReduction_256 -happyReduction_256 (HappyAbsSyn58 happy_var_3) - _ - (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn86 - (Alt happy_var_1 happy_var_3 - ) -happyReduction_256 _ _ _ = notHappyAtAll - -happyReduce_257 = happySpecReduce_0 87# happyReduction_257 -happyReduction_257 = HappyAbsSyn87 - ([] - ) - -happyReduce_258 = happySpecReduce_1 87# happyReduction_258 -happyReduction_258 (HappyAbsSyn86 happy_var_1) - = HappyAbsSyn87 - ((:[]) happy_var_1 - ) -happyReduction_258 _ = notHappyAtAll - -happyReduce_259 = happySpecReduce_3 87# happyReduction_259 -happyReduction_259 (HappyAbsSyn87 happy_var_3) - _ - (HappyAbsSyn86 happy_var_1) - = HappyAbsSyn87 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_259 _ _ _ = notHappyAtAll - -happyReduce_260 = happyReduce 5# 88# happyReduction_260 -happyReduction_260 (_ `HappyStk` - (HappyAbsSyn58 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn76 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn88 - (DDDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_261 = happySpecReduce_1 88# happyReduction_261 -happyReduction_261 (HappyAbsSyn58 happy_var_1) - = HappyAbsSyn88 - (DDExp happy_var_1 - ) -happyReduction_261 _ = notHappyAtAll - -happyReduce_262 = happySpecReduce_0 89# happyReduction_262 -happyReduction_262 = HappyAbsSyn89 - ([] - ) - -happyReduce_263 = happySpecReduce_2 89# happyReduction_263 -happyReduction_263 (HappyAbsSyn88 happy_var_2) - (HappyAbsSyn89 happy_var_1) - = HappyAbsSyn89 - (flip (:) happy_var_1 happy_var_2 - ) -happyReduction_263 _ _ = notHappyAtAll - -happyReduce_264 = happySpecReduce_2 90# happyReduction_264 -happyReduction_264 (HappyAbsSyn25 happy_var_2) - (HappyAbsSyn91 happy_var_1) - = HappyAbsSyn90 - (OldGr happy_var_1 (reverse happy_var_2) - ) -happyReduction_264 _ _ = notHappyAtAll - -happyReduce_265 = happySpecReduce_0 91# happyReduction_265 -happyReduction_265 = HappyAbsSyn91 - (NoIncl - ) - -happyReduce_266 = happySpecReduce_2 91# happyReduction_266 -happyReduction_266 (HappyAbsSyn93 happy_var_2) - _ - = HappyAbsSyn91 - (Incl happy_var_2 - ) -happyReduction_266 _ _ = notHappyAtAll - -happyReduce_267 = happySpecReduce_1 92# happyReduction_267 -happyReduction_267 (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn92 - (FString happy_var_1 - ) -happyReduction_267 _ = notHappyAtAll - -happyReduce_268 = happySpecReduce_1 92# happyReduction_268 -happyReduction_268 (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn92 - (FIdent happy_var_1 - ) -happyReduction_268 _ = notHappyAtAll - -happyReduce_269 = happySpecReduce_2 92# happyReduction_269 -happyReduction_269 (HappyAbsSyn92 happy_var_2) - _ - = HappyAbsSyn92 - (FSlash happy_var_2 - ) -happyReduction_269 _ _ = notHappyAtAll - -happyReduce_270 = happySpecReduce_2 92# happyReduction_270 -happyReduction_270 (HappyAbsSyn92 happy_var_2) - _ - = HappyAbsSyn92 - (FDot happy_var_2 - ) -happyReduction_270 _ _ = notHappyAtAll - -happyReduce_271 = happySpecReduce_2 92# happyReduction_271 -happyReduction_271 (HappyAbsSyn92 happy_var_2) - _ - = HappyAbsSyn92 - (FMinus happy_var_2 - ) -happyReduction_271 _ _ = notHappyAtAll - -happyReduce_272 = happySpecReduce_2 92# happyReduction_272 -happyReduction_272 (HappyAbsSyn92 happy_var_2) - (HappyAbsSyn12 happy_var_1) - = HappyAbsSyn92 - (FAddId happy_var_1 happy_var_2 - ) -happyReduction_272 _ _ = notHappyAtAll - -happyReduce_273 = happySpecReduce_2 93# happyReduction_273 -happyReduction_273 _ - (HappyAbsSyn92 happy_var_1) - = HappyAbsSyn93 - ((:[]) happy_var_1 - ) -happyReduction_273 _ _ = notHappyAtAll - -happyReduce_274 = happySpecReduce_3 93# happyReduction_274 -happyReduction_274 (HappyAbsSyn93 happy_var_3) - _ - (HappyAbsSyn92 happy_var_1) - = HappyAbsSyn93 - ((:) happy_var_1 happy_var_3 - ) -happyReduction_274 _ _ _ = notHappyAtAll - -happyNewToken action sts stk [] = - action 176# 176# notHappyAtAll (HappyState action) sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = action i i tk (HappyState action) sts stk tks in - case tk of { - PT _ (TS ";") -> cont 94#; - PT _ (TS "=") -> cont 95#; - PT _ (TS "{") -> cont 96#; - PT _ (TS "}") -> cont 97#; - PT _ (TS "(") -> cont 98#; - PT _ (TS ")") -> cont 99#; - PT _ (TS ":") -> cont 100#; - PT _ (TS "->") -> cont 101#; - PT _ (TS "**") -> cont 102#; - PT _ (TS ",") -> cont 103#; - PT _ (TS "[") -> cont 104#; - PT _ (TS "]") -> cont 105#; - PT _ (TS "-") -> cont 106#; - PT _ (TS ".") -> cont 107#; - PT _ (TS "|") -> cont 108#; - PT _ (TS "%") -> cont 109#; - PT _ (TS "?") -> cont 110#; - PT _ (TS "<") -> cont 111#; - PT _ (TS ">") -> cont 112#; - PT _ (TS "@") -> cont 113#; - PT _ (TS "#") -> cont 114#; - PT _ (TS "!") -> cont 115#; - PT _ (TS "*") -> cont 116#; - PT _ (TS "+") -> cont 117#; - PT _ (TS "++") -> cont 118#; - PT _ (TS "\\") -> cont 119#; - PT _ (TS "=>") -> cont 120#; - PT _ (TS "_") -> cont 121#; - PT _ (TS "$") -> cont 122#; - PT _ (TS "/") -> cont 123#; - PT _ (TS "Lin") -> cont 124#; - PT _ (TS "PType") -> cont 125#; - PT _ (TS "Str") -> cont 126#; - PT _ (TS "Strs") -> cont 127#; - PT _ (TS "Tok") -> cont 128#; - PT _ (TS "Type") -> cont 129#; - PT _ (TS "abstract") -> cont 130#; - PT _ (TS "case") -> cont 131#; - PT _ (TS "cat") -> cont 132#; - PT _ (TS "concrete") -> cont 133#; - PT _ (TS "data") -> cont 134#; - PT _ (TS "def") -> cont 135#; - PT _ (TS "flags") -> cont 136#; - PT _ (TS "fn") -> cont 137#; - PT _ (TS "fun") -> cont 138#; - PT _ (TS "grammar") -> cont 139#; - PT _ (TS "in") -> cont 140#; - PT _ (TS "include") -> cont 141#; - PT _ (TS "incomplete") -> cont 142#; - PT _ (TS "instance") -> cont 143#; - PT _ (TS "interface") -> cont 144#; - PT _ (TS "let") -> cont 145#; - PT _ (TS "lin") -> cont 146#; - PT _ (TS "lincat") -> cont 147#; - PT _ (TS "lindef") -> cont 148#; - PT _ (TS "lintype") -> cont 149#; - PT _ (TS "of") -> cont 150#; - PT _ (TS "open") -> cont 151#; - PT _ (TS "oper") -> cont 152#; - PT _ (TS "out") -> cont 153#; - PT _ (TS "package") -> cont 154#; - PT _ (TS "param") -> cont 155#; - PT _ (TS "pattern") -> cont 156#; - PT _ (TS "pre") -> cont 157#; - PT _ (TS "printname") -> cont 158#; - PT _ (TS "resource") -> cont 159#; - PT _ (TS "reuse") -> cont 160#; - PT _ (TS "strs") -> cont 161#; - PT _ (TS "table") -> cont 162#; - PT _ (TS "tokenizer") -> cont 163#; - PT _ (TS "transfer") -> cont 164#; - PT _ (TS "union") -> cont 165#; - PT _ (TS "var") -> cont 166#; - PT _ (TS "variants") -> cont 167#; - PT _ (TS "where") -> cont 168#; - PT _ (TS "with") -> cont 169#; - PT _ (TI happy_dollar_dollar) -> cont 170#; - PT _ (TL happy_dollar_dollar) -> cont 171#; - PT _ (TD happy_dollar_dollar) -> cont 172#; - PT _ (T_LString happy_dollar_dollar) -> cont 173#; - PT _ (T_PIdent _) -> cont 174#; - _ -> cont 175#; - _ -> 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 action_0 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll }) - -pModDef tks = happySomeParser where - happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn15 z -> happyReturn z; _other -> notHappyAtAll }) - -pOldGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn90 z -> happyReturn z; _other -> notHappyAtAll }) - -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn58 z -> happyReturn z; _other -> notHappyAtAll }) - -pModHeader tks = happySomeParser where - happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn15 z -> happyReturn z; _other -> notHappyAtAll }) - -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 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - -{-# LINE 28 "templates/GenericTemplate.hs" #-} - - - - - - - - -{-# LINE 49 "templates/GenericTemplate.hs" #-} - -{-# LINE 59 "templates/GenericTemplate.hs" #-} - -{-# LINE 68 "templates/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 1#, 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 1# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j ) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - -{-# LINE 155 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - - -newtype HappyState b c = HappyState - (Int# -> -- token number - Int# -> -- token number (yes, again) - b -> -- token semantic value - HappyState b c -> -- current state - [HappyState b c] -> -- state stack - c) - - - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 1# tk st sts stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (I# (i)) -> i }) in --- trace "shifting the error token" $ - new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 1# tk st sts stk - = happyFail 1# tk st sts stk -happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk - = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 1# tk st sts stk - = happyFail 1# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 1# tk st sts stk - = happyFail 1# tk st sts stk -happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 1# tk st sts stk - = happyFail 1# tk st sts stk -happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 1# tk st sts stk - = happyFail 1# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@(((st1@(HappyState (action))):(_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (action nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 1# tk st sts stk - = happyFail 1# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts)) - drop_stk = happyDropStk k stk - -happyMonad2Reduce k nt fn 1# tk st sts stk - = happyFail 1# 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@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts)) - drop_stk = happyDropStk k stk - - - - - - new_state = action - - -happyDrop 0# l = l -happyDrop n ((_):(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 - -{-# LINE 253 "templates/GenericTemplate.hs" #-} -happyGoto action j tk st = action j j tk (HappyState action) - - ------------------------------------------------------------------------------ --- Error recovery (1# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 1# 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 1# tk old_st (((HappyState (action))):(sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - action 1# 1# tk (HappyState (action)) sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (HappyState (action)) sts stk = --- trace "entering error recovery" $ - action 1# 1# tk (HappyState (action)) sts ( (HappyErrorToken (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. - -{-# LINE 317 "templates/GenericTemplate.hs" #-} -{-# 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/GF/Source/ParGF.y b/src/GF/Source/ParGF.y deleted file mode 100644 index 2109434e5..000000000 --- a/src/GF/Source/ParGF.y +++ /dev/null @@ -1,642 +0,0 @@ --- This Happy file was machine-generated by the BNF converter -{ -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} - module GF.Source.ParGF (pGrammar, pModDef, pOldGrammar, pExp, pModHeader, myLexer) where --H -import GF.Source.AbsGF --H -import GF.Source.LexGF --H -import GF.Infra.Ident --H -import GF.Data.ErrM --H -} - -%name pGrammar Grammar -%name pModDef ModDef -%name pOldGrammar OldGrammar -%name pExp Exp -%partial pModHeader ModHeader - --- 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 "\\") } - '=>' { PT _ (TS "=>") } - '_' { PT _ (TS "_") } - '$' { PT _ (TS "$") } - '/' { PT _ (TS "/") } - 'Lin' { PT _ (TS "Lin") } - 'PType' { PT _ (TS "PType") } - 'Str' { PT _ (TS "Str") } - 'Strs' { PT _ (TS "Strs") } - 'Tok' { PT _ (TS "Tok") } - 'Type' { PT _ (TS "Type") } - 'abstract' { PT _ (TS "abstract") } - 'case' { PT _ (TS "case") } - 'cat' { PT _ (TS "cat") } - 'concrete' { PT _ (TS "concrete") } - 'data' { PT _ (TS "data") } - 'def' { PT _ (TS "def") } - 'flags' { PT _ (TS "flags") } - 'fn' { PT _ (TS "fn") } - 'fun' { PT _ (TS "fun") } - 'grammar' { PT _ (TS "grammar") } - 'in' { PT _ (TS "in") } - 'include' { PT _ (TS "include") } - 'incomplete' { PT _ (TS "incomplete") } - 'instance' { PT _ (TS "instance") } - 'interface' { PT _ (TS "interface") } - 'let' { PT _ (TS "let") } - 'lin' { PT _ (TS "lin") } - 'lincat' { PT _ (TS "lincat") } - 'lindef' { PT _ (TS "lindef") } - 'lintype' { PT _ (TS "lintype") } - 'of' { PT _ (TS "of") } - 'open' { PT _ (TS "open") } - 'oper' { PT _ (TS "oper") } - 'out' { PT _ (TS "out") } - 'package' { PT _ (TS "package") } - 'param' { PT _ (TS "param") } - 'pattern' { PT _ (TS "pattern") } - 'pre' { PT _ (TS "pre") } - 'printname' { PT _ (TS "printname") } - 'resource' { PT _ (TS "resource") } - 'reuse' { PT _ (TS "reuse") } - 'strs' { PT _ (TS "strs") } - 'table' { PT _ (TS "table") } - 'tokenizer' { PT _ (TS "tokenizer") } - 'transfer' { PT _ (TS "transfer") } - 'union' { PT _ (TS "union") } - 'var' { PT _ (TS "var") } - 'variants' { PT _ (TS "variants") } - 'where' { PT _ (TS "where") } - 'with' { PT _ (TS "with") } - -L_integ { PT _ (TI $$) } -L_quoted { PT _ (TL $$) } -L_doubl { PT _ (TD $$) } -L_LString { PT _ (T_LString $$) } -L_PIdent { PT _ (T_PIdent _) } -L_err { _ } - - -%% - -Integer :: { Integer } : L_integ { (read $1) :: Integer } -String :: { String } : L_quoted { $1 } -Double :: { Double } : L_doubl { (read $1) :: Double } -LString :: { LString} : L_LString { LString ($1)} -PIdent :: { PIdent} : L_PIdent { PIdent (mkPosToken $1)} - -Grammar :: { Grammar } -Grammar : ListModDef { Gr (reverse $1) } - - -ListModDef :: { [ModDef] } -ListModDef : {- empty -} { [] } - | ListModDef ModDef { flip (:) $1 $2 } - - -ModDef :: { ModDef } -ModDef : ModDef ';' { $1 } - | 'grammar' PIdent '=' '{' 'abstract' '=' PIdent ';' ListConcSpec '}' { MMain $2 $7 $9 } - | ComplMod ModType '=' ModBody { MModule $1 $2 $4 } - - -ConcSpec :: { ConcSpec } -ConcSpec : PIdent '=' ConcExp { ConcSpec $1 $3 } - - -ListConcSpec :: { [ConcSpec] } -ListConcSpec : {- empty -} { [] } - | ConcSpec { (:[]) $1 } - | ConcSpec ';' ListConcSpec { (:) $1 $3 } - - -ConcExp :: { ConcExp } -ConcExp : PIdent ListTransfer { ConcExp $1 (reverse $2) } - - -ListTransfer :: { [Transfer] } -ListTransfer : {- empty -} { [] } - | ListTransfer Transfer { flip (:) $1 $2 } - - -Transfer :: { Transfer } -Transfer : '(' 'transfer' 'in' Open ')' { TransferIn $4 } - | '(' 'transfer' 'out' Open ')' { TransferOut $4 } - - -ModHeader :: { ModDef } -ModHeader : ComplMod ModType '=' ModHeaderBody { MModule $1 $2 $4 } - - -ModHeaderBody :: { ModBody } -ModHeaderBody : Extend Opens { MBody $1 $2 [] } - | ListIncluded { MNoBody $1 } - | Included 'with' ListOpen { MWith $1 $3 } - | Included 'with' ListOpen '**' Opens { MWithBody $1 $3 $5 [] } - | ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 } - | ListIncluded '**' Included 'with' ListOpen '**' Opens { MWithEBody $1 $3 $5 $7 [] } - | 'reuse' PIdent { MReuse $2 } - | 'union' ListIncluded { MUnion $2 } - - -ModType :: { ModType } -ModType : 'abstract' PIdent { MTAbstract $2 } - | 'resource' PIdent { MTResource $2 } - | 'interface' PIdent { MTInterface $2 } - | 'concrete' PIdent 'of' PIdent { MTConcrete $2 $4 } - | 'instance' PIdent 'of' PIdent { MTInstance $2 $4 } - | 'transfer' PIdent ':' Open '->' Open { MTTransfer $2 $4 $6 } - - -ModBody :: { ModBody } -ModBody : Extend Opens '{' ListTopDef '}' { MBody $1 $2 (reverse $4) } - | ListIncluded { MNoBody $1 } - | Included 'with' ListOpen { MWith $1 $3 } - | Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithBody $1 $3 $5 (reverse $7) } - | ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 } - | ListIncluded '**' Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithEBody $1 $3 $5 $7 (reverse $9) } - | 'reuse' PIdent { MReuse $2 } - | 'union' ListIncluded { MUnion $2 } - - -ListTopDef :: { [TopDef] } -ListTopDef : {- empty -} { [] } - | ListTopDef TopDef { flip (:) $1 $2 } - - -Extend :: { Extend } -Extend : ListIncluded '**' { Ext $1 } - | {- empty -} { NoExt } - - -ListOpen :: { [Open] } -ListOpen : {- empty -} { [] } - | Open { (:[]) $1 } - | Open ',' ListOpen { (:) $1 $3 } - - -Opens :: { Opens } -Opens : {- empty -} { NoOpens } - | 'open' ListOpen 'in' { OpenIn $2 } - - -Open :: { Open } -Open : PIdent { OName $1 } - | '(' QualOpen PIdent ')' { OQualQO $2 $3 } - | '(' QualOpen PIdent '=' PIdent ')' { OQual $2 $3 $5 } - - -ComplMod :: { ComplMod } -ComplMod : {- empty -} { CMCompl } - | 'incomplete' { CMIncompl } - - -QualOpen :: { QualOpen } -QualOpen : {- empty -} { QOCompl } - | 'incomplete' { QOIncompl } - | 'interface' { QOInterface } - - -ListIncluded :: { [Included] } -ListIncluded : {- empty -} { [] } - | Included { (:[]) $1 } - | Included ',' ListIncluded { (:) $1 $3 } - - -Included :: { Included } -Included : PIdent { IAll $1 } - | PIdent '[' ListPIdent ']' { ISome $1 $3 } - | PIdent '-' '[' ListPIdent ']' { IMinus $1 $4 } - - -Def :: { Def } -Def : ListName ':' Exp { DDecl $1 $3 } - | ListName '=' Exp { DDef $1 $3 } - | Name ListPatt '=' Exp { DPatt $1 $2 $4 } - | ListName ':' Exp '=' Exp { DFull $1 $3 $5 } - - -TopDef :: { TopDef } -TopDef : 'cat' ListCatDef { DefCat $2 } - | 'fun' ListFunDef { DefFun $2 } - | 'data' ListFunDef { DefFunData $2 } - | 'def' ListDef { DefDef $2 } - | 'data' ListDataDef { DefData $2 } - | 'transfer' ListDef { DefTrans $2 } - | 'param' ListParDef { DefPar $2 } - | 'oper' ListDef { DefOper $2 } - | 'lincat' ListPrintDef { DefLincat $2 } - | 'lindef' ListDef { DefLindef $2 } - | 'lin' ListDef { DefLin $2 } - | 'printname' 'cat' ListPrintDef { DefPrintCat $3 } - | 'printname' 'fun' ListPrintDef { DefPrintFun $3 } - | 'flags' ListFlagDef { DefFlag $2 } - | 'printname' ListPrintDef { DefPrintOld $2 } - | 'lintype' ListDef { DefLintype $2 } - | 'pattern' ListDef { DefPattern $2 } - | 'package' PIdent '=' '{' ListTopDef '}' ';' { DefPackage $2 (reverse $5) } - | 'var' ListDef { DefVars $2 } - | 'tokenizer' PIdent ';' { DefTokenizer $2 } - - -CatDef :: { CatDef } -CatDef : PIdent ListDDecl { SimpleCatDef $1 (reverse $2) } - | '[' PIdent ListDDecl ']' { ListCatDef $2 (reverse $3) } - | '[' PIdent ListDDecl ']' '{' Integer '}' { ListSizeCatDef $2 (reverse $3) $6 } - - -FunDef :: { FunDef } -FunDef : ListPIdent ':' Exp { FunDef $1 $3 } - - -DataDef :: { DataDef } -DataDef : PIdent '=' ListDataConstr { DataDef $1 $3 } - - -DataConstr :: { DataConstr } -DataConstr : PIdent { DataId $1 } - | PIdent '.' PIdent { DataQId $1 $3 } - - -ListDataConstr :: { [DataConstr] } -ListDataConstr : {- empty -} { [] } - | DataConstr { (:[]) $1 } - | DataConstr '|' ListDataConstr { (:) $1 $3 } - - -ParDef :: { ParDef } -ParDef : PIdent '=' ListParConstr { ParDefDir $1 $3 } - | PIdent '=' '(' 'in' PIdent ')' { ParDefIndir $1 $5 } - | PIdent { ParDefAbs $1 } - - -ParConstr :: { ParConstr } -ParConstr : PIdent ListDDecl { ParConstr $1 (reverse $2) } - - -PrintDef :: { PrintDef } -PrintDef : ListName '=' Exp { PrintDef $1 $3 } - - -FlagDef :: { FlagDef } -FlagDef : PIdent '=' PIdent { FlagDef $1 $3 } - - -ListDef :: { [Def] } -ListDef : Def ';' { (:[]) $1 } - | Def ';' ListDef { (:) $1 $3 } - - -ListCatDef :: { [CatDef] } -ListCatDef : CatDef ';' { (:[]) $1 } - | CatDef ';' ListCatDef { (:) $1 $3 } - - -ListFunDef :: { [FunDef] } -ListFunDef : FunDef ';' { (:[]) $1 } - | FunDef ';' ListFunDef { (:) $1 $3 } - - -ListDataDef :: { [DataDef] } -ListDataDef : DataDef ';' { (:[]) $1 } - | DataDef ';' ListDataDef { (:) $1 $3 } - - -ListParDef :: { [ParDef] } -ListParDef : ParDef ';' { (:[]) $1 } - | ParDef ';' ListParDef { (:) $1 $3 } - - -ListPrintDef :: { [PrintDef] } -ListPrintDef : PrintDef ';' { (:[]) $1 } - | PrintDef ';' ListPrintDef { (:) $1 $3 } - - -ListFlagDef :: { [FlagDef] } -ListFlagDef : FlagDef ';' { (:[]) $1 } - | FlagDef ';' ListFlagDef { (:) $1 $3 } - - -ListParConstr :: { [ParConstr] } -ListParConstr : {- empty -} { [] } - | ParConstr { (:[]) $1 } - | ParConstr '|' ListParConstr { (:) $1 $3 } - - -ListPIdent :: { [PIdent] } -ListPIdent : PIdent { (:[]) $1 } - | PIdent ',' ListPIdent { (:) $1 $3 } - - -Name :: { Name } -Name : PIdent { IdentName $1 } - | '[' PIdent ']' { ListName $2 } - - -ListName :: { [Name] } -ListName : Name { (:[]) $1 } - | Name ',' ListName { (:) $1 $3 } - - -LocDef :: { LocDef } -LocDef : ListPIdent ':' Exp { LDDecl $1 $3 } - | ListPIdent '=' Exp { LDDef $1 $3 } - | ListPIdent ':' Exp '=' Exp { LDFull $1 $3 $5 } - - -ListLocDef :: { [LocDef] } -ListLocDef : {- empty -} { [] } - | LocDef { (:[]) $1 } - | LocDef ';' ListLocDef { (:) $1 $3 } - - -Exp6 :: { Exp } -Exp6 : PIdent { EIdent $1 } - | '{' PIdent '}' { EConstr $2 } - | '%' PIdent '%' { ECons $2 } - | Sort { ESort $1 } - | String { EString $1 } - | Integer { EInt $1 } - | Double { EFloat $1 } - | '?' { EMeta } - | '[' ']' { EEmpty } - | 'data' { EData } - | '[' PIdent Exps ']' { EList $2 $3 } - | '[' String ']' { EStrings $2 } - | '{' ListLocDef '}' { ERecord $2 } - | '<' ListTupleComp '>' { ETuple $2 } - | '(' 'in' PIdent ')' { EIndir $3 } - | '<' Exp ':' Exp '>' { ETyped $2 $4 } - | '(' Exp ')' { $2 } - | LString { ELString $1 } - - -Exp5 :: { Exp } -Exp5 : Exp5 '.' Label { EProj $1 $3 } - | '{' PIdent '.' PIdent '}' { EQConstr $2 $4 } - | '%' PIdent '.' PIdent { EQCons $2 $4 } - | Exp6 { $1 } - - -Exp4 :: { Exp } -Exp4 : Exp4 Exp5 { EApp $1 $2 } - | 'table' '{' ListCase '}' { ETable $3 } - | 'table' Exp6 '{' ListCase '}' { ETTable $2 $4 } - | 'table' Exp6 '[' ListExp ']' { EVTable $2 $4 } - | 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 } - | 'variants' '{' ListExp '}' { EVariants $3 } - | 'pre' '{' Exp ';' ListAltern '}' { EPre $3 $5 } - | 'strs' '{' ListExp '}' { EStrs $3 } - | PIdent '@' Exp6 { EConAt $1 $3 } - | '#' Patt2 { EPatt $2 } - | 'pattern' Exp5 { EPattType $2 } - | Exp5 { $1 } - | 'Lin' PIdent { ELin $2 } - - -Exp3 :: { Exp } -Exp3 : Exp3 '!' Exp4 { ESelect $1 $3 } - | Exp3 '*' Exp4 { ETupTyp $1 $3 } - | Exp3 '**' Exp4 { EExtend $1 $3 } - | Exp4 { $1 } - - -Exp1 :: { Exp } -Exp1 : Exp2 '+' Exp1 { EGlue $1 $3 } - | Exp2 { $1 } - - -Exp :: { Exp } -Exp : Exp1 '++' Exp { EConcat $1 $3 } - | '\\' ListBind '->' Exp { EAbstr $2 $4 } - | '\\' '\\' ListBind '=>' Exp { ECTable $3 $5 } - | Decl '->' Exp { EProd $1 $3 } - | Exp3 '=>' Exp { ETType $1 $3 } - | 'let' '{' ListLocDef '}' 'in' Exp { ELet $3 $6 } - | 'let' ListLocDef 'in' Exp { ELetb $2 $4 } - | Exp3 'where' '{' ListLocDef '}' { EWhere $1 $4 } - | 'fn' '{' ListEquation '}' { EEqs $3 } - | 'in' Exp5 String { EExample $2 $3 } - | Exp1 { $1 } - - -Exp2 :: { Exp } -Exp2 : Exp3 { $1 } - - -ListExp :: { [Exp] } -ListExp : {- empty -} { [] } - | Exp { (:[]) $1 } - | Exp ';' ListExp { (:) $1 $3 } - - -Exps :: { Exps } -Exps : {- empty -} { NilExp } - | Exp6 Exps { ConsExp $1 $2 } - - -Patt2 :: { Patt } -Patt2 : '?' { PChar } - | '[' String ']' { PChars $2 } - | '#' PIdent { PMacro $2 } - | '#' PIdent '.' PIdent { PM $2 $4 } - | '_' { PW } - | PIdent { PV $1 } - | '{' PIdent '}' { PCon $2 } - | PIdent '.' PIdent { PQ $1 $3 } - | Integer { PInt $1 } - | Double { PFloat $1 } - | String { PStr $1 } - | '{' ListPattAss '}' { PR $2 } - | '<' ListPattTupleComp '>' { PTup $2 } - | '(' Patt ')' { $2 } - - -Patt1 :: { Patt } -Patt1 : PIdent ListPatt { PC $1 $2 } - | PIdent '.' PIdent ListPatt { PQC $1 $3 $4 } - | Patt2 '*' { PRep $1 } - | PIdent '@' Patt2 { PAs $1 $3 } - | '-' Patt2 { PNeg $2 } - | Patt2 { $1 } - - -Patt :: { Patt } -Patt : Patt '|' Patt1 { PDisj $1 $3 } - | Patt '+' Patt1 { PSeq $1 $3 } - | Patt1 { $1 } - - -PattAss :: { PattAss } -PattAss : ListPIdent '=' Patt { PA $1 $3 } - - -Label :: { Label } -Label : PIdent { LIdent $1 } - | '$' Integer { LVar $2 } - - -Sort :: { Sort } -Sort : 'Type' { Sort_Type } - | 'PType' { Sort_PType } - | 'Tok' { Sort_Tok } - | 'Str' { Sort_Str } - | 'Strs' { Sort_Strs } - - -ListPattAss :: { [PattAss] } -ListPattAss : {- empty -} { [] } - | PattAss { (:[]) $1 } - | PattAss ';' ListPattAss { (:) $1 $3 } - - -ListPatt :: { [Patt] } -ListPatt : Patt2 { (:[]) $1 } - | Patt2 ListPatt { (:) $1 $2 } - - -Bind :: { Bind } -Bind : PIdent { BIdent $1 } - | '_' { BWild } - - -ListBind :: { [Bind] } -ListBind : {- empty -} { [] } - | Bind { (:[]) $1 } - | Bind ',' ListBind { (:) $1 $3 } - - -Decl :: { Decl } -Decl : '(' ListBind ':' Exp ')' { DDec $2 $4 } - | Exp4 { DExp $1 } - - -TupleComp :: { TupleComp } -TupleComp : Exp { TComp $1 } - - -PattTupleComp :: { PattTupleComp } -PattTupleComp : Patt { PTComp $1 } - - -ListTupleComp :: { [TupleComp] } -ListTupleComp : {- empty -} { [] } - | TupleComp { (:[]) $1 } - | TupleComp ',' ListTupleComp { (:) $1 $3 } - - -ListPattTupleComp :: { [PattTupleComp] } -ListPattTupleComp : {- empty -} { [] } - | PattTupleComp { (:[]) $1 } - | PattTupleComp ',' ListPattTupleComp { (:) $1 $3 } - - -Case :: { Case } -Case : Patt '=>' Exp { Case $1 $3 } - - -ListCase :: { [Case] } -ListCase : Case { (:[]) $1 } - | Case ';' ListCase { (:) $1 $3 } - - -Equation :: { Equation } -Equation : ListPatt '->' Exp { Equ $1 $3 } - - -ListEquation :: { [Equation] } -ListEquation : {- empty -} { [] } - | Equation { (:[]) $1 } - | Equation ';' ListEquation { (:) $1 $3 } - - -Altern :: { Altern } -Altern : Exp '/' Exp { Alt $1 $3 } - - -ListAltern :: { [Altern] } -ListAltern : {- empty -} { [] } - | Altern { (:[]) $1 } - | Altern ';' ListAltern { (:) $1 $3 } - - -DDecl :: { DDecl } -DDecl : '(' ListBind ':' Exp ')' { DDDec $2 $4 } - | Exp6 { DDExp $1 } - - -ListDDecl :: { [DDecl] } -ListDDecl : {- empty -} { [] } - | ListDDecl DDecl { flip (:) $1 $2 } - - -OldGrammar :: { OldGrammar } -OldGrammar : Include ListTopDef { OldGr $1 (reverse $2) } - - -Include :: { Include } -Include : {- empty -} { NoIncl } - | 'include' ListFileName { Incl $2 } - - -FileName :: { FileName } -FileName : String { FString $1 } - | PIdent { FIdent $1 } - | '/' FileName { FSlash $2 } - | '.' FileName { FDot $2 } - | '-' FileName { FMinus $2 } - | PIdent FileName { FAddId $1 $2 } - - -ListFileName :: { [FileName] } -ListFileName : FileName ';' { (:[]) $1 } - | FileName ';' ListFileName { (:) $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 ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -} - diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs deleted file mode 100644 index 0a260f5bf..000000000 --- a/src/GF/Source/PrintGF.hs +++ /dev/null @@ -1,532 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Source.PrintGF where - --- pretty-printer generated by the BNF converter - -import GF.Source.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 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 - MMain pident0 pident concspecs -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident0 , doc (showString "=") , doc (showString "{") , doc (showString "abstract") , doc (showString "=") , prt 0 pident , doc (showString ";") , prt 0 concspecs , doc (showString "}")]) - 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 ConcSpec where - prt i e = case e of - ConcSpec pident concexp -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 concexp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print ConcExp where - prt i e = case e of - ConcExp pident transfers -> prPrec i 0 (concatD [prt 0 pident , prt 0 transfers]) - - -instance Print Transfer where - prt i e = case e of - TransferIn open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "in") , prt 0 open , doc (showString ")")]) - TransferOut open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "out") , prt 0 open , 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 - MTAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident]) - MTResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident]) - MTInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident]) - MTConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - MTInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - MTTransfer pident open0 open -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 pident , doc (showString ":") , prt 0 open0 , doc (showString "->") , prt 0 open]) - - -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]) - OQualQO qualopen pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident , doc (showString ")")]) - OQual qualopen pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , 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 QualOpen where - prt i e = case e of - QOCompl -> prPrec i 0 (concatD []) - QOIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")]) - QOInterface -> prPrec i 0 (concatD [doc (showString "interface")]) - - -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 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 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]) - DefTrans defs -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 defs]) - 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 printdefs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 printdefs]) - 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 printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 printdefs]) - DefPrintFun printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 printdefs]) - DefFlag flagdefs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 flagdefs]) - DefPrintOld printdefs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 printdefs]) - 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 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 FunDef where - prt i e = case e of - FunDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , 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 DataDef where - prt i e = case e of - DataDef pident dataconstrs -> prPrec i 0 (concatD [prt 0 pident , 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]) - ParDefIndir pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")]) - 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 PrintDef where - prt i e = case e of - PrintDef 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 FlagDef where - prt i e = case e of - FlagDef pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , 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 Name where - prt i e = case e of - IdentName 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 - EIdent 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 "}")]) - EConAt pident exp -> prPrec i 4 (concatD [prt 0 pident , doc (showString "@") , prt 6 exp]) - EPatt patt -> prPrec i 4 (concatD [doc (showString "#") , prt 2 patt]) - EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , 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 - LIdent 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 - BIdent 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]) - FIdent 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/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs deleted file mode 100644 index 3bd192f9d..000000000 --- a/src/GF/Source/SkelGF.hs +++ /dev/null @@ -1,364 +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 - - -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/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs deleted file mode 100644 index 132bd4704..000000000 --- a/src/GF/Source/SourceToGrammar.hs +++ /dev/null @@ -1,755 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SourceToGrammar --- 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.Source.SourceToGrammar ( transGrammar, - transInclude, - transModDef, - transOldGrammar, - transExp, - newReservedWords - ) where - -import qualified GF.Grammar.Grammar as G -import qualified GF.Grammar.PrGrammar as GP -import qualified GF.Infra.Modules as GM -import qualified GF.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.Source.AbsGF -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 Data.List (genericReplicate) - --- 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 - -prPIdent :: PIdent -> String -prPIdent (PIdent (_,c)) = c - -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 - IdentName i -> transIdent i - ListName i -> liftM mkListId (transIdent i) - -transGrammar :: Grammar -> Err G.SourceGrammar -transGrammar x = case x of - Gr moddefs -> do - moddefs' <- mapM transModDef moddefs - GD.mkSourceGrammar moddefs' - -transModDef :: ModDef -> Err (Ident, G.SourceModInfo) -transModDef x = case x of - - MMain id0 id concspecs -> do - id0' <- transIdent id0 - id' <- transIdent id - concspecs' <- mapM transConcSpec concspecs - return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs')) - - MModule compl mtyp body -> do - - let mstat' = transComplMod compl - - (trDef, mtyp', id') <- case mtyp of - MTAbstract id -> do - id' <- transIdent id - return (transAbsDef, GM.MTAbstract, id') - MTResource id -> mkModRes id GM.MTResource body - MTConcrete id open -> do - id' <- transIdent id - open' <- transIdent open - return (transCncDef, GM.MTConcrete open', id') - MTTransfer id a b -> do - id' <- transIdent id - a' <- transOpen a - b' <- transOpen a - return (transAbsDef, GM.MTTransfer a' b', id') - MTInterface id -> mkModRes id GM.MTInterface body - MTInstance id open -> do - open' <- transIdent open - mkModRes id (GM.MTInstance open') body - - mkBody (mstat', trDef, mtyp', id') body - where - mkBody xx@(mstat', 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 - defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] - flags' <- return [f | Right fs <- defs0, f <- fs] - return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs')) - MReuse _ -> do - return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree)) - MUnion imps -> do - imps' <- mapM transIncluded imps - return (id', - GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] emptyBinTree)) - - 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 - defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] - flags' <- return [f | Right fs <- defs0, f <- fs] - return (id', - GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts') - - mkModRes id mtyp body = do - id' <- transIdent id - case body of - MReuse c -> do - c' <- transIdent c - mtyp' <- trMReuseType mtyp c' - return (transResDef, GM.MTReuse mtyp', id') - _ -> return (transResDef, mtyp, id') - trMReuseType mtyp c = case mtyp of - GM.MTInterface -> return $ GM.MRInterface c - GM.MTInstance op -> return $ GM.MRInstance c op - GM.MTResource -> return $ GM.MRResource c - - -transComplMod :: ComplMod -> GM.ModuleStatus -transComplMod x = case x of - CMCompl -> GM.MSComplete - CMIncompl -> GM.MSIncomplete - -getTopDefs :: [TopDef] -> [TopDef] -getTopDefs x = x - -transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident) -transConcSpec x = case x of - ConcSpec id concexp -> do - id' <- transIdent id - (m,mi,mo) <- transConcExp concexp - return $ GM.MainConcreteSpec id' m mi mo - -transConcExp :: ConcExp -> - Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident)) -transConcExp x = case x of - ConcExp id transfers -> do - id' <- transIdent id - trs <- mapM transTransfer transfers - tin <- case [o | Left o <- trs] of - [o] -> return $ Just o - [] -> return $ Nothing - _ -> Bad "ambiguous transfer in" - tout <- case [o | Right o <- trs] of - [o] -> return $ Just o - [] -> return $ Nothing - _ -> Bad "ambiguous transfer out" - return (id',tin,tout) - -transTransfer :: Transfer -> - Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident)) -transTransfer x = case x of - TransferIn open -> liftM Left $ transOpen open - TransferOut open -> liftM Right $ transOpen open - -transExtend :: Extend -> Err [(Ident,GM.MInclude Ident)] -transExtend x = case x of - Ext ids -> mapM transIncludedExt ids - NoExt -> return [] - -transOpens :: Opens -> Err [GM.OpenSpec Ident] -transOpens x = case x of - NoOpens -> return [] - OpenIn opens -> mapM transOpen opens - -transOpen :: Open -> Err (GM.OpenSpec Ident) -transOpen x = case x of - OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id - OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id) - OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m) - -transQualOpen :: QualOpen -> Err GM.OpenQualif -transQualOpen x = case x of - QOCompl -> return GM.OQNormal - QOInterface -> return GM.OQInterface - QOIncompl -> return GM.OQIncomplete - -transIncluded :: Included -> Err (Ident,[Ident]) -transIncluded x = case x of - IAll i -> liftM (flip (curry id) []) $ transIdent i - ISome i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) - IMinus i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ---- - -transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident) -transIncludedExt x = case x of - IAll i -> liftM2 (,) (transIdent i) (return GM.MIAll) - ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids) - IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids) - -transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) -transAbsDef x = case x of - DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs - DefFun fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl [(fun, G.AbsFun (yes typ) nope) | (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] - DefTrans defs -> do - defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- defs'] - DefFlag defs -> liftM Right $ mapM transFlagDef defs - _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x - where - -- to get data constructors as terms - funs t = case t of - G.Cn f -> [f] - G.Q _ f -> [f] - G.QC _ f -> [f] - _ -> [] - -returnl :: a -> Err (Either a b) -returnl = return . Left - -transFlagDef :: FlagDef -> Err GO.Option -transFlagDef x = case x of - FlagDef f x -> return $ GO.Opt (prPIdent f,[prPIdent x]) - --- | Cat definitions can also return some fun defs --- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, G.Info)] -transCatDef x = case x of - SimpleCatDef id ddecls -> do - id' <- transIdent id - liftM (:[]) $ cat id' ddecls - ListCatDef id ddecls -> listCat id ddecls 0 - ListSizeCatDef id ddecls size -> listCat id ddecls size - where - cat i ddecls = do - -- i <- transIdent id - cont <- liftM concat $ mapM transDDecl ddecls - return (i, G.AbsCat (yes cont) nope) - listCat id ddecls size = do - id' <- transIdent id - let - li = mkListId id' - baseId = mkBaseId id' - consId = mkConsId id' - catd0@(c,G.AbsCat (Yes cont0) _) <- cat li ddecls - let - catd = (c,G.AbsCat (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 = M.mkProdSimple (cont ++ genericReplicate size cd) lc - nilfund = (baseId, G.AbsFun (yes niltyp) (yes G.EData)) - constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc - consfund = (consId, G.AbsFun (yes constyp) (yes G.EData)) - return [catd,nilfund,consfund] - mkId x i = if isWildIdent x then (mkIdent "x" i) else x - -transFunDef :: FunDef -> Err ([Ident], G.Type) -transFunDef x = case x of - FunDef ids typ -> liftM2 (,) (mapM transIdent 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.Cn $ transIdent id - DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) - -transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) -transResDef x = case x of - DefPar pardefs -> do - pardefs' <- mapM transParDef pardefs - returnl $ [(p, G.ResParam (if null pars - then nope -- abstract param type - else (yes (pars,Nothing)))) - | (p,pars) <- pardefs'] - ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) | - (p,pars) <- pardefs', (f,co) <- pars] - -{- - ---- encoding of AnyInd without changing syntax. AR 20/9/2007 - DefOper [DDef [c] (EApp (EInt status) (EIdent mo))] -> do - c' <- transName c - mo' <- transIdent mo - return $ Left [(c',G.AnyInd (status==1) mo')] --} - DefOper defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl $ concatMap mkOverload [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] - - DefLintype defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] - - DefFlag defs -> liftM Right $ mapM transFlagDef defs - _ -> Bad $ "illegal definition form in resource" +++ printTree x - where - mkOverload (c,j) = case j of - G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) | - isOverloading keyw c fs -> - [(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] - - -- to enable separare type signature --- not type-checked - G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ | - isOverloading keyw c fs -> [] - _ -> [(c,j)] - isOverloading keyw c fs = - GP.prt keyw == "overload" && -- overload is a "soft keyword" - all (== GP.prt c) (map (GP.prt . fst) fs) - -transParDef :: ParDef -> Err (Ident, [G.Param]) -transParDef x = case x of - ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) - ParDefAbs id -> liftM2 (,) (transIdent id) (return []) - _ -> Bad $ "illegal definition in resource:" ++++ printTree x - -transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) -transCncDef x = case x of - DefLincat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, G.CncCat (yes t) nope nope) | (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, G.CncFun Nothing pe nope) | (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] - - _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x - -transPrintDef :: PrintDef -> Err [(Ident,G.Term)] -transPrintDef x = case x of - PrintDef ids exp -> do - (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) - return $ [(i,e) | i <- ids] - -getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] -getDefsGen d = case d of - DDecl ids t -> do - ids' <- mapM transName ids - t' <- transExp t - return [(i,(yes 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')])))] - --- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh 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, yes (M.mkAbs xs e')))] - _ -> getDefsGen d - --- | 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" +++ GP.prt p' - -transExp :: Exp -> Err G.Term -transExp x = case x of - EIdent id -> liftM G.Vr $ transIdent id - EConstr id -> liftM G.Con $ transIdent id - ECons id -> liftM G.Cn $ 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 $ M.meta $ M.int2meta 0 - EEmpty -> return G.Empty - -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n) - EList i es -> do - i' <- transIdent i - es' <- mapM transExp (exps2list es) - return $ foldl G.App (G.Vr (mkListId i')) 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.Strs $ 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 M.mkProdSimple (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" +++ GP.prt 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 - - _ -> 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" +++ GP.prt (fst f) --- manifest fields ?! - tryR f = case f of - (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) - _ -> Bad $ "illegal record field" +++ GP.prt (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 compatibility and should be removed - LIdent (PIdent (_,'v':ds@(_:_))) | all isDigit ds -> return $ G.LVar $ readIntArg ds - - LIdent (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 - -{- ---- no more used 7/1/2006 AR -transPatts :: Patt -> Err [G.Patt] -transPatts p = case p of - PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2) - PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts - PQC q id patts -> liftM (map (G.PP q id) . combinations) (mapM transPatts patts) - - PR pattasss -> do - let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] - ls = map LIdent $ concat lss - ps0 <- mapM transPatts ps - let ps' = combinations ps0 - lss' <- mapM trLabel ls - let rss = map (zip lss') ps' - return $ map G.PR rss - PTup pcs -> do - ps0 <- mapM transPatts [e | PTComp e <- pcs] - let ps' = combinations ps0 - return $ map (G.PR . M.tuple2recordPatt) ps' - _ -> liftM singleton $ transPatt p --} - -transPatt :: Patt -> Err G.Patt -transPatt x = case x of - PW -> return G.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 LIdent $ 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) - 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) - -transBind :: Bind -> Err Ident -transBind x = case x of - BIdent 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 G.Param -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 = identPI $ maybe topic id $ getOptVal opts useAbsName - resName = identPI $ maybe ("Res" ++ lang) id $ getOptVal opts useResName - cncName = identPI $ maybe lang id $ getOptVal opts useCncName - - identPI s = PIdent ((0,0),s) - - (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 (PIdent (_, s)) -> modif s - FSlash filename -> '/' : trans filename - FDot filename -> '.' : trans filename - FMinus filename -> '-' : trans filename - FAddId (PIdent (_, 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 :: Ident -> Ident -mkListId = prefixId "List" -mkConsId = prefixId "Cons" -mkBaseId = prefixId "Base" - -prefixId :: String -> Ident -> Ident -prefixId pref id = IC (pref ++ prIdent id) diff --git a/src/GF/Source/TestGF.hs b/src/GF/Source/TestGF.hs deleted file mode 100644 index e4c072467..000000000 --- a/src/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/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs deleted file mode 100644 index 7e6f80ba1..000000000 --- a/src/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/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs deleted file mode 100644 index 35274e3c4..000000000 --- a/src/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/GF/Speech/GrammarToVoiceXML.hs b/src/GF/Speech/GrammarToVoiceXML.hs deleted file mode 100644 index ad7f25d1c..000000000 --- a/src/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/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs deleted file mode 100644 index 1a0ebe0c0..000000000 --- a/src/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/GF/Speech/PrFA.hs b/src/GF/Speech/PrFA.hs deleted file mode 100644 index 2856039ec..000000000 --- a/src/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/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs deleted file mode 100644 index 248991380..000000000 --- a/src/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/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs deleted file mode 100644 index 037a4f4e2..000000000 --- a/src/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/GF/Speech/PrRegExp.hs b/src/GF/Speech/PrRegExp.hs deleted file mode 100644 index 55a25d69b..000000000 --- a/src/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/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs deleted file mode 100644 index 9bc025558..000000000 --- a/src/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/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs deleted file mode 100644 index d8ae07867..000000000 --- a/src/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/GF/Speech/PrSRGS_ABNF.hs b/src/GF/Speech/PrSRGS_ABNF.hs deleted file mode 100644 index abb84c5dc..000000000 --- a/src/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/GF/Speech/RegExp.hs b/src/GF/Speech/RegExp.hs deleted file mode 100644 index 5ee40828e..000000000 --- a/src/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/GF/Speech/Relation.hs b/src/GF/Speech/Relation.hs deleted file mode 100644 index 641d671a9..000000000 --- a/src/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/GF/Speech/RelationQC.hs b/src/GF/Speech/RelationQC.hs deleted file mode 100644 index 47f783986..000000000 --- a/src/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/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs deleted file mode 100644 index 3e68a2e55..000000000 --- a/src/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/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs deleted file mode 100644 index 19b6c1c1b..000000000 --- a/src/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/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs deleted file mode 100644 index 3d7ebd809..000000000 --- a/src/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/GF/System/ATKSpeechInput.hs b/src/GF/System/ATKSpeechInput.hs deleted file mode 100644 index 4b50293af..000000000 --- a/src/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/GF/System/Arch.hs b/src/GF/System/Arch.hs deleted file mode 100644 index c0dac3644..000000000 --- a/src/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/GF/System/ArchEdit.hs b/src/GF/System/ArchEdit.hs deleted file mode 100644 index 39b558cef..000000000 --- a/src/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/GF/System/NoReadline.hs b/src/GF/System/NoReadline.hs deleted file mode 100644 index 138ba4e28..000000000 --- a/src/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/GF/System/NoSignal.hs b/src/GF/System/NoSignal.hs deleted file mode 100644 index 5d82a431e..000000000 --- a/src/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/GF/System/NoSpeechInput.hs b/src/GF/System/NoSpeechInput.hs deleted file mode 100644 index 04197ce92..000000000 --- a/src/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/GF/System/Readline.hs b/src/GF/System/Readline.hs deleted file mode 100644 index c12493f98..000000000 --- a/src/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/GF/System/Signal.hs b/src/GF/System/Signal.hs deleted file mode 100644 index fe8a12483..000000000 --- a/src/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/GF/System/SpeechInput.hs b/src/GF/System/SpeechInput.hs deleted file mode 100644 index 6c2374473..000000000 --- a/src/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/GF/System/Tracing.hs b/src/GF/System/Tracing.hs deleted file mode 100644 index 71bacfb75..000000000 --- a/src/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/GF/System/UseReadline.hs b/src/GF/System/UseReadline.hs deleted file mode 100644 index c84b9d7f4..000000000 --- a/src/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/GF/System/UseSignal.hs b/src/GF/System/UseSignal.hs deleted file mode 100644 index 5e6d81237..000000000 --- a/src/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/GF/Text/Arabic.hs b/src/GF/Text/Arabic.hs deleted file mode 100644 index c482b1172..000000000 --- a/src/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/GF/Text/Devanagari.hs b/src/GF/Text/Devanagari.hs deleted file mode 100644 index bf4343cd0..000000000 --- a/src/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/GF/Text/Ethiopic.hs b/src/GF/Text/Ethiopic.hs deleted file mode 100644 index 81abbf719..000000000 --- a/src/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/GF/Text/ExtendedArabic.hs b/src/GF/Text/ExtendedArabic.hs deleted file mode 100644 index d2c5faac5..000000000 --- a/src/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/GF/Text/ExtraDiacritics.hs b/src/GF/Text/ExtraDiacritics.hs deleted file mode 100644 index f3d811c2c..000000000 --- a/src/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/GF/Text/Greek.hs b/src/GF/Text/Greek.hs deleted file mode 100644 index 6b9361a29..000000000 --- a/src/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/GF/Text/Hebrew.hs b/src/GF/Text/Hebrew.hs deleted file mode 100644 index c7026d8da..000000000 --- a/src/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/GF/Text/Hiragana.hs b/src/GF/Text/Hiragana.hs deleted file mode 100644 index ba74fc83c..000000000 --- a/src/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/GF/Text/LatinASupplement.hs b/src/GF/Text/LatinASupplement.hs deleted file mode 100644 index f42423c91..000000000 --- a/src/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/GF/Text/OCSCyrillic.hs b/src/GF/Text/OCSCyrillic.hs deleted file mode 100644 index 0d4696944..000000000 --- a/src/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/GF/Text/Russian.hs b/src/GF/Text/Russian.hs deleted file mode 100644 index c4f1bfd89..000000000 --- a/src/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/GF/Text/Tamil.hs b/src/GF/Text/Tamil.hs deleted file mode 100644 index 8ee171acf..000000000 --- a/src/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/GF/Text/Text.hs b/src/GF/Text/Text.hs deleted file mode 100644 index b55355c20..000000000 --- a/src/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/GF/Text/Thai.hs b/src/GF/Text/Thai.hs deleted file mode 100644 index 1b186cb3a..000000000 --- a/src/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/GF/Text/UTF8.hs b/src/GF/Text/UTF8.hs deleted file mode 100644 index 5e9687684..000000000 --- a/src/GF/Text/UTF8.hs +++ /dev/null @@ -1,48 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : UTF8 --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:42 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- From the Char module supplied with HBC. --- code by Thomas Hallgren (Jul 10 1999) ------------------------------------------------------------------------------ - -module GF.Text.UTF8 (decodeUTF8, encodeUTF8) where - --- | Take a Unicode string and encode it as a string --- with the UTF8 method. -decodeUTF8 :: String -> String -decodeUTF8 "" = "" -decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs -decodeUTF8 (c:c':cs) | '\xc0' <= c && c <= '\xdf' && - '\x80' <= c' && c' <= '\xbf' = - toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs -decodeUTF8 (c:c':c'':cs) | '\xe0' <= c && c <= '\xef' && - '\x80' <= c' && c' <= '\xbf' && - '\x80' <= c'' && c'' <= '\xbf' = - toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs -decodeUTF8 s = s ---- AR workaround 22/6/2006 -----decodeUTF8 _ = error "UniChar.decodeUTF8: bad data" - -encodeUTF8 :: String -> String -encodeUTF8 "" = "" -encodeUTF8 (c:cs) = - if c > '\x0000' && c < '\x0080' then - c : encodeUTF8 cs - else if c < toEnum 0x0800 then - let i = fromEnum c - in toEnum (0xc0 + i `div` 0x40) : - toEnum (0x80 + i `mod` 0x40) : - encodeUTF8 cs - else - let i = fromEnum c - in toEnum (0xe0 + i `div` 0x1000) : - toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : - toEnum (0x80 + i `mod` 0x40) : - encodeUTF8 cs diff --git a/src/GF/Text/Unicode.hs b/src/GF/Text/Unicode.hs deleted file mode 100644 index 9d0b9d1a8..000000000 --- a/src/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/GF/Translate/GFT.hs b/src/GF/Translate/GFT.hs deleted file mode 100644 index e4a9d8193..000000000 --- a/src/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/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs deleted file mode 100644 index 983b7f683..000000000 --- a/src/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/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs deleted file mode 100644 index 762562eb0..000000000 --- a/src/GF/UseGrammar/Editing.hs +++ /dev/null @@ -1,435 +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.Grammar.Macros (errorCat) - -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 errorCat . 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/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs deleted file mode 100644 index 5f07e0b85..000000000 --- a/src/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/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs deleted file mode 100644 index e980a3d95..000000000 --- a/src/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/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs deleted file mode 100644 index 4526980d6..000000000 --- a/src/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/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs deleted file mode 100644 index c9b94ccb0..000000000 --- a/src/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/GF/UseGrammar/MatchTerm.hs b/src/GF/UseGrammar/MatchTerm.hs deleted file mode 100644 index 9acffd44c..000000000 --- a/src/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/GF/UseGrammar/Morphology.hs b/src/GF/UseGrammar/Morphology.hs deleted file mode 100644 index 3aeb08dc7..000000000 --- a/src/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/GF/UseGrammar/Paraphrases.hs b/src/GF/UseGrammar/Paraphrases.hs deleted file mode 100644 index d04f22aa6..000000000 --- a/src/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/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs deleted file mode 100644 index 2ca057410..000000000 --- a/src/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/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs deleted file mode 100644 index c1c77edb2..000000000 --- a/src/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/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs deleted file mode 100644 index e54d0e3fb..000000000 --- a/src/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/GF/UseGrammar/Statistics.hs b/src/GF/UseGrammar/Statistics.hs deleted file mode 100644 index 46e4fcc3b..000000000 --- a/src/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/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs deleted file mode 100644 index 9f1ab5449..000000000 --- a/src/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/GF/UseGrammar/Transfer.hs b/src/GF/UseGrammar/Transfer.hs deleted file mode 100644 index 5d62f4385..000000000 --- a/src/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/GF/UseGrammar/TreeSelections.hs b/src/GF/UseGrammar/TreeSelections.hs deleted file mode 100644 index 9bf2711be..000000000 --- a/src/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/GF/UseGrammar/Treebank.hs b/src/GF/UseGrammar/Treebank.hs deleted file mode 100644 index 841a9c6dc..000000000 --- a/src/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/GF/Visualization/Graphviz.hs b/src/GF/Visualization/Graphviz.hs deleted file mode 100644 index b59e3ecd2..000000000 --- a/src/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/GF/Visualization/VisualizeGrammar.hs b/src/GF/Visualization/VisualizeGrammar.hs deleted file mode 100644 index b5446aec8..000000000 --- a/src/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/GF/Visualization/VisualizeTree.hs b/src/GF/Visualization/VisualizeTree.hs deleted file mode 100644 index 5fe740c12..000000000 --- a/src/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" -- cgit v1.2.3