From 055c0d0d5a5bb0dc75904fe53df7f2e4f5732a8f Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 21 May 2008 09:26:44 +0000 Subject: GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3 --- src-3.0/GF/API.hs | 472 ++ src-3.0/GF/API/BatchTranslate.hs | 43 + src-3.0/GF/API/GrammarToHaskell.hs | 271 + src-3.0/GF/API/GrammarToTransfer.hs | 94 + src-3.0/GF/API/IOGrammar.hs | 96 + src-3.0/GF/API/MyParser.hs | 25 + src-3.0/GF/CF/CF.hs | 213 + src-3.0/GF/CF/CFIdent.hs | 253 + src-3.0/GF/CF/CFtoGrammar.hs | 62 + src-3.0/GF/CF/CanonToCF.hs | 214 + src-3.0/GF/CF/ChartParser.hs | 206 + src-3.0/GF/CF/EBNF.hs | 191 + src-3.0/GF/CF/PPrCF.hs | 102 + src-3.0/GF/CF/PrLBNF.hs | 150 + src-3.0/GF/CF/Profile.hs | 106 + src-3.0/GF/CFGM/AbsCFG.hs | 45 + src-3.0/GF/CFGM/CFG.cf | 36 + src-3.0/GF/CFGM/LexCFG.hs | 312 + src-3.0/GF/CFGM/LexCFG.x | 135 + src-3.0/GF/CFGM/ParCFG.hs | 779 ++ src-3.0/GF/CFGM/ParCFG.y | 129 + src-3.0/GF/CFGM/PrintCFG.hs | 157 + src-3.0/GF/CFGM/PrintCFGrammar.hs | 113 + src-3.0/GF/Canon/AbsGFC.hs | 182 + src-3.0/GF/Canon/AbsToBNF.hs | 38 + src-3.0/GF/Canon/CMacros.hs | 334 + src-3.0/GF/Canon/CanonToGFCC.hs | 45 + src-3.0/GF/Canon/CanonToGrammar.hs | 203 + src-3.0/GF/Canon/GFC.cf | 170 + src-3.0/GF/Canon/GFC.hs | 103 + src-3.0/GF/Canon/GetGFC.hs | 78 + src-3.0/GF/Canon/LexGFC.hs | 346 + src-3.0/GF/Canon/LexGFC.x | 132 + src-3.0/GF/Canon/Look.hs | 225 + src-3.0/GF/Canon/MkGFC.hs | 237 + src-3.0/GF/Canon/ParGFC.hs | 2142 ++++++ src-3.0/GF/Canon/ParGFC.y | 385 + src-3.0/GF/Canon/PrExp.hs | 46 + src-3.0/GF/Canon/PrintGFC.hs | 376 + src-3.0/GF/Canon/Share.hs | 147 + src-3.0/GF/Canon/SkelGFC.hs | 217 + src-3.0/GF/Canon/Subexpressions.hs | 170 + src-3.0/GF/Canon/TestGFC.hs | 58 + src-3.0/GF/Canon/Unlex.hs | 49 + src-3.0/GF/Canon/Unparametrize.hs | 63 + src-3.0/GF/Canon/log.txt | 20 + src-3.0/GF/Command/AbsGFShell.hs | 42 + src-3.0/GF/Command/Commands.hs | 159 + src-3.0/GF/Command/GFShell.cf | 27 + src-3.0/GF/Command/Importing.hs | 28 + src-3.0/GF/Command/Interpreter.hs | 74 + src-3.0/GF/Command/LexGFShell.hs | 337 + src-3.0/GF/Command/PPrTree.hs | 39 + src-3.0/GF/Command/ParGFShell.hs | 809 ++ src-3.0/GF/Command/PrintGFShell.hs | 144 + src-3.0/GF/Compile/API.hs | 21 + src-3.0/GF/Compile/BackOpt.hs | 141 + src-3.0/GF/Compile/CheckGrammar.hs | 1078 +++ src-3.0/GF/Compile/Compile.hs | 401 + src-3.0/GF/Compile/Evaluate.hs | 477 ++ src-3.0/GF/Compile/Extend.hs | 136 + src-3.0/GF/Compile/Flatten.hs | 92 + src-3.0/GF/Compile/GetGrammar.hs | 146 + src-3.0/GF/Compile/GrammarToCanon.hs | 293 + src-3.0/GF/Compile/MkConcrete.hs | 154 + src-3.0/GF/Compile/MkResource.hs | 128 + src-3.0/GF/Compile/MkUnion.hs | 83 + src-3.0/GF/Compile/ModDeps.hs | 153 + src-3.0/GF/Compile/NewRename.hs | 294 + src-3.0/GF/Compile/NoParse.hs | 49 + src-3.0/GF/Compile/Optimize.hs | 300 + src-3.0/GF/Compile/PGrammar.hs | 77 + src-3.0/GF/Compile/PrOld.hs | 84 + src-3.0/GF/Compile/Rebuild.hs | 99 + src-3.0/GF/Compile/RemoveLiT.hs | 63 + src-3.0/GF/Compile/Rename.hs | 338 + src-3.0/GF/Compile/ShellState.hs | 568 ++ src-3.0/GF/Compile/Update.hs | 135 + src-3.0/GF/Compile/Wordlist.hs | 108 + src-3.0/GF/Conversion/GFC.hs | 157 + src-3.0/GF/Conversion/GFCtoSimple.hs | 175 + src-3.0/GF/Conversion/Haskell.hs | 71 + src-3.0/GF/Conversion/MCFGtoCFG.hs | 53 + src-3.0/GF/Conversion/MCFGtoFCFG.hs | 51 + src-3.0/GF/Conversion/Prolog.hs | 205 + src-3.0/GF/Conversion/RemoveEpsilon.hs | 46 + src-3.0/GF/Conversion/RemoveErasing.hs | 113 + src-3.0/GF/Conversion/RemoveSingletons.hs | 82 + src-3.0/GF/Conversion/SimpleToFCFG.hs | 536 ++ src-3.0/GF/Conversion/SimpleToFinite.hs | 178 + src-3.0/GF/Conversion/SimpleToMCFG.hs | 26 + src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs | 63 + src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs | 256 + src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs | 129 + src-3.0/GF/Conversion/TypeGraph.hs | 58 + src-3.0/GF/Conversion/Types.hs | 146 + src-3.0/GF/Data/Assoc.hs | 143 + src-3.0/GF/Data/BacktrackM.hs | 93 + src-3.0/GF/Data/Compos.hs | 37 + src-3.0/GF/Data/ErrM.hs | 38 + src-3.0/GF/Data/GeneralDeduction.hs | 121 + src-3.0/GF/Data/Glue.hs | 30 + src-3.0/GF/Data/IncrementalDeduction.hs | 67 + src-3.0/GF/Data/Map.hs | 61 + src-3.0/GF/Data/Operations.hs | 658 ++ src-3.0/GF/Data/OrdMap2.hs | 127 + src-3.0/GF/Data/OrdSet.hs | 120 + src-3.0/GF/Data/Parsers.hs | 196 + src-3.0/GF/Data/RedBlack.hs | 64 + src-3.0/GF/Data/RedBlackSet.hs | 150 + src-3.0/GF/Data/SharedString.hs | 19 + src-3.0/GF/Data/SortedList.hs | 127 + src-3.0/GF/Data/Str.hs | 134 + src-3.0/GF/Data/Trie.hs | 129 + src-3.0/GF/Data/Trie2.hs | 120 + src-3.0/GF/Data/Utilities.hs | 190 + src-3.0/GF/Data/XML.hs | 57 + src-3.0/GF/Data/Zipper.hs | 257 + src-3.0/GF/Devel/AbsCompute.hs | 145 + src-3.0/GF/Devel/Arch.hs | 89 + src-3.0/GF/Devel/CheckGrammar.hs | 1090 +++ src-3.0/GF/Devel/CheckM.hs | 89 + src-3.0/GF/Devel/Compile.hs | 203 + src-3.0/GF/Devel/Compile/AbsGF.hs | 274 + src-3.0/GF/Devel/Compile/CheckGrammar.hs | 1089 +++ src-3.0/GF/Devel/Compile/Compile.hs | 205 + src-3.0/GF/Devel/Compile/ErrM.hs | 26 + src-3.0/GF/Devel/Compile/Extend.hs | 154 + src-3.0/GF/Devel/Compile/Factorize.hs | 251 + src-3.0/GF/Devel/Compile/GF.cf | 326 + src-3.0/GF/Devel/Compile/GFC.hs | 72 + src-3.0/GF/Devel/Compile/GFtoGFCC.hs | 542 ++ src-3.0/GF/Devel/Compile/GetGrammar.hs | 56 + src-3.0/GF/Devel/Compile/LexGF.hs | 343 + src-3.0/GF/Devel/Compile/Optimize.hs | 333 + src-3.0/GF/Devel/Compile/ParGF.hs | 3210 ++++++++ src-3.0/GF/Devel/Compile/PrintGF.hs | 481 ++ src-3.0/GF/Devel/Compile/Refresh.hs | 118 + src-3.0/GF/Devel/Compile/Rename.hs | 239 + src-3.0/GF/Devel/Compile/SourceToGF.hs | 679 ++ src-3.0/GF/Devel/Compute.hs | 455 ++ src-3.0/GF/Devel/GF.hs | 14 + src-3.0/GF/Devel/GFC.hs | 67 + src-3.0/GF/Devel/GFC/Main.hs | 28 + src-3.0/GF/Devel/GFCCInterpreter.hs | 28 + src-3.0/GF/Devel/GFCCtoHaskell.hs | 213 + src-3.0/GF/Devel/GFCCtoJS.hs | 132 + src-3.0/GF/Devel/GFI.hs | 77 + src-3.0/GF/Devel/GetGrammar.hs | 54 + src-3.0/GF/Devel/Grammar/AppPredefined.hs | 166 + src-3.0/GF/Devel/Grammar/Compute.hs | 380 + src-3.0/GF/Devel/Grammar/Construct.hs | 221 + src-3.0/GF/Devel/Grammar/GFtoSource.hs | 223 + src-3.0/GF/Devel/Grammar/Grammar.hs | 172 + src-3.0/GF/Devel/Grammar/Lookup.hs | 168 + src-3.0/GF/Devel/Grammar/Macros.hs | 434 ++ src-3.0/GF/Devel/Grammar/PatternMatch.hs | 146 + src-3.0/GF/Devel/Grammar/PrGF.hs | 246 + src-3.0/GF/Devel/GrammarToGFCC.hs | 545 ++ src-3.0/GF/Devel/Infra/ReadFiles.hs | 348 + src-3.0/GF/Devel/ModDeps.hs | 153 + src-3.0/GF/Devel/Optimize.hs | 299 + src-3.0/GF/Devel/OptimizeGF.hs | 271 + src-3.0/GF/Devel/Options.hs | 269 + src-3.0/GF/Devel/PrGrammar.hs | 233 + src-3.0/GF/Devel/PrintGFCC.hs | 21 + src-3.0/GF/Devel/README-testgf3 | 49 + src-3.0/GF/Devel/ReadFiles.hs | 196 + src-3.0/GF/Devel/TC.hs | 299 + src-3.0/GF/Devel/TestGF3.hs | 9 + src-3.0/GF/Devel/TypeCheck.hs | 311 + src-3.0/GF/Devel/UseIO.hs | 298 + src-3.0/GF/Devel/gf-code.txt | 66 + src-3.0/GF/Devel/gf3.txt | 84 + src-3.0/GF/Embed/EmbedAPI.hs | 114 + src-3.0/GF/Embed/EmbedCustom.hs | 113 + src-3.0/GF/Embed/EmbedParsing.hs | 65 + src-3.0/GF/Embed/TemplateApp.hs | 44 + src-3.0/GF/Formalism/CFG.hs | 50 + src-3.0/GF/Formalism/FCFG.hs | 106 + src-3.0/GF/Formalism/GCFG.hs | 47 + src-3.0/GF/Formalism/MCFG.hs | 58 + src-3.0/GF/Formalism/SimpleGFC.hs | 268 + src-3.0/GF/Formalism/Utilities.hs | 423 ++ src-3.0/GF/Fudgets/ArchEdit.hs | 30 + src-3.0/GF/Fudgets/CommandF.hs | 134 + src-3.0/GF/Fudgets/EventF.hs | 51 + src-3.0/GF/Fudgets/FudgetOps.hs | 59 + src-3.0/GF/Fudgets/UnicodeF.hs | 37 + src-3.0/GF/GFCC/API.hs | 140 + src-3.0/GF/GFCC/CId.hs | 14 + src-3.0/GF/GFCC/CheckGFCC.hs | 186 + src-3.0/GF/GFCC/ComposOp.hs | 30 + src-3.0/GF/GFCC/DataGFCC.hs | 152 + src-3.0/GF/GFCC/GFCC.cf | 81 + src-3.0/GF/GFCC/Generate.hs | 70 + src-3.0/GF/GFCC/LexGFCC.hs | 349 + src-3.0/GF/GFCC/Linearize.hs | 91 + src-3.0/GF/GFCC/Macros.hs | 121 + src-3.0/GF/GFCC/OptimizeGFCC.hs | 116 + src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs | 17 + src-3.0/GF/GFCC/Raw/ConvertGFCC.hs | 277 + src-3.0/GF/GFCC/Raw/GFCCRaw.cf | 12 + src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs | 99 + src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs | 36 + src-3.0/GF/GFCC/ShowLinearize.hs | 87 + src-3.0/GF/GFCC/SkelGFCC.hs | 109 + src-3.0/GF/GFCC/TestGFCC.hs | 58 + src-3.0/GF/GFCC/doc/Eng.gf | 13 + src-3.0/GF/GFCC/doc/Ex.gf | 8 + src-3.0/GF/GFCC/doc/Swe.gf | 13 + src-3.0/GF/GFCC/doc/Test.gf | 64 + src-3.0/GF/GFCC/doc/gfcc.html | 809 ++ src-3.0/GF/GFCC/doc/gfcc.txt | 712 ++ src-3.0/GF/GFCC/doc/old-GFCC.cf | 50 + src-3.0/GF/GFCC/doc/old-gfcc.txt | 656 ++ src-3.0/GF/GFCC/doc/syntax.txt | 180 + src-3.0/GF/GFModes.hs | 112 + src-3.0/GF/Grammar/AbsCompute.hs | 145 + src-3.0/GF/Grammar/Abstract.hs | 38 + src-3.0/GF/Grammar/AppPredefined.hs | 159 + src-3.0/GF/Grammar/Compute.hs | 426 ++ src-3.0/GF/Grammar/Grammar.hs | 244 + src-3.0/GF/Grammar/Lockfield.hs | 46 + src-3.0/GF/Grammar/LookAbs.hs | 196 + src-3.0/GF/Grammar/Lookup.hs | 275 + src-3.0/GF/Grammar/MMacros.hs | 341 + src-3.0/GF/Grammar/Macros.hs | 814 ++ src-3.0/GF/Grammar/PatternMatch.hs | 155 + src-3.0/GF/Grammar/PrGrammar.hs | 286 + src-3.0/GF/Grammar/Refresh.hs | 133 + src-3.0/GF/Grammar/ReservedWords.hs | 44 + src-3.0/GF/Grammar/SGrammar.hs | 169 + src-3.0/GF/Grammar/TC.hs | 299 + src-3.0/GF/Grammar/TypeCheck.hs | 311 + src-3.0/GF/Grammar/Unify.hs | 96 + src-3.0/GF/Grammar/Values.hs | 109 + src-3.0/GF/IDE/IDECommands.hs | 95 + src-3.0/GF/Infra/CheckM.hs | 89 + src-3.0/GF/Infra/Comments.hs | 43 + src-3.0/GF/Infra/CompactPrint.hs | 22 + src-3.0/GF/Infra/Ident.hs | 155 + src-3.0/GF/Infra/Modules.hs | 416 ++ src-3.0/GF/Infra/Option.hs | 375 + src-3.0/GF/Infra/Print.hs | 127 + src-3.0/GF/Infra/PrintClass.hs | 51 + src-3.0/GF/Infra/ReadFiles.hs | 362 + src-3.0/GF/Infra/UseIO.hs | 330 + src-3.0/GF/JavaScript/AbsJS.hs | 60 + src-3.0/GF/JavaScript/JS.cf | 55 + src-3.0/GF/JavaScript/LexJS.hs | 337 + src-3.0/GF/JavaScript/LexJS.x | 132 + src-3.0/GF/JavaScript/Makefile | 14 + src-3.0/GF/JavaScript/ParJS.hs | 1175 +++ src-3.0/GF/JavaScript/ParJS.y | 225 + src-3.0/GF/JavaScript/PrintJS.hs | 169 + src-3.0/GF/JavaScript/SkelJS.hs | 80 + src-3.0/GF/JavaScript/TestJS.hs | 58 + src-3.0/GF/OldParsing/CFGrammar.hs | 153 + src-3.0/GF/OldParsing/ConvertFiniteGFC.hs | 283 + src-3.0/GF/OldParsing/ConvertFiniteSimple.hs | 121 + src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs | 34 + .../GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs | 71 + src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs | 281 + src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs | 277 + src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs | 189 + src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs | 122 + src-3.0/GF/OldParsing/ConvertGrammar.hs | 44 + src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs | 52 + src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs | 30 + .../GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs | 70 + .../GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs | 245 + src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs | 277 + .../GF/OldParsing/ConvertSimpleToMCFG/Strict.hs | 139 + src-3.0/GF/OldParsing/GCFG.hs | 43 + src-3.0/GF/OldParsing/GeneralChart.hs | 86 + src-3.0/GF/OldParsing/GrammarTypes.hs | 148 + src-3.0/GF/OldParsing/IncrementalChart.hs | 50 + src-3.0/GF/OldParsing/MCFGrammar.hs | 206 + src-3.0/GF/OldParsing/ParseCF.hs | 82 + src-3.0/GF/OldParsing/ParseCFG.hs | 43 + src-3.0/GF/OldParsing/ParseCFG/General.hs | 83 + src-3.0/GF/OldParsing/ParseCFG/Incremental.hs | 142 + src-3.0/GF/OldParsing/ParseGFC.hs | 177 + src-3.0/GF/OldParsing/ParseMCFG.hs | 37 + src-3.0/GF/OldParsing/ParseMCFG/Basic.hs | 156 + src-3.0/GF/OldParsing/SimpleGFC.hs | 161 + src-3.0/GF/OldParsing/Utilities.hs | 188 + src-3.0/GF/Parsing/CF.hs | 66 + src-3.0/GF/Parsing/CFG.hs | 51 + src-3.0/GF/Parsing/CFG/General.hs | 103 + src-3.0/GF/Parsing/CFG/Incremental.hs | 150 + src-3.0/GF/Parsing/CFG/PInfo.hs | 98 + src-3.0/GF/Parsing/FCFG.hs | 100 + src-3.0/GF/Parsing/FCFG/Active.hs | 179 + src-3.0/GF/Parsing/FCFG/Incremental.hs | 107 + src-3.0/GF/Parsing/FCFG/PInfo.hs | 121 + src-3.0/GF/Parsing/FCFG/Range.hs | 50 + src-3.0/GF/Parsing/GFC.hs | 208 + src-3.0/GF/Parsing/MCFG.hs | 68 + src-3.0/GF/Parsing/MCFG/Active.hs | 318 + src-3.0/GF/Parsing/MCFG/Active2.hs | 237 + src-3.0/GF/Parsing/MCFG/FastActive.hs | 176 + src-3.0/GF/Parsing/MCFG/Incremental.hs | 178 + src-3.0/GF/Parsing/MCFG/Incremental2.hs | 157 + src-3.0/GF/Parsing/MCFG/Naive.hs | 142 + src-3.0/GF/Parsing/MCFG/PInfo.hs | 162 + src-3.0/GF/Parsing/MCFG/Range.hs | 206 + src-3.0/GF/Parsing/MCFG/ViaCFG.hs | 186 + src-3.0/GF/Printing/PrintParser.hs | 83 + src-3.0/GF/Printing/PrintSimplifiedTerm.hs | 127 + src-3.0/GF/Probabilistic/Probabilistic.hs | 203 + src-3.0/GF/Shell.hs | 591 ++ src-3.0/GF/Shell/CommandL.hs | 198 + src-3.0/GF/Shell/Commands.hs | 568 ++ src-3.0/GF/Shell/HelpFile.hs | 723 ++ src-3.0/GF/Shell/JGF.hs | 89 + src-3.0/GF/Shell/PShell.hs | 174 + src-3.0/GF/Shell/ShellCommands.hs | 246 + src-3.0/GF/Shell/SubShell.hs | 66 + src-3.0/GF/Shell/TeachYourself.hs | 87 + src-3.0/GF/Source/AbsGF.hs | 306 + src-3.0/GF/Source/ErrM.hs | 26 + src-3.0/GF/Source/GF.cf | 370 + src-3.0/GF/Source/GrammarToSource.hs | 259 + src-3.0/GF/Source/LexGF.hs | 345 + src-3.0/GF/Source/LexGF.x | 137 + src-3.0/GF/Source/ParGF.hs | 7845 ++++++++++++++++++++ src-3.0/GF/Source/ParGF.y | 642 ++ src-3.0/GF/Source/PrintGF.hs | 532 ++ src-3.0/GF/Source/SkelGF.hs | 364 + src-3.0/GF/Source/SourceToGrammar.hs | 755 ++ src-3.0/GF/Source/TestGF.hs | 58 + src-3.0/GF/Speech/CFGToFiniteState.hs | 265 + src-3.0/GF/Speech/FiniteState.hs | 329 + src-3.0/GF/Speech/GrammarToVoiceXML.hs | 285 + src-3.0/GF/Speech/Graph.hs | 178 + src-3.0/GF/Speech/PrFA.hs | 56 + src-3.0/GF/Speech/PrGSL.hs | 113 + src-3.0/GF/Speech/PrJSGF.hs | 145 + src-3.0/GF/Speech/PrRegExp.hs | 33 + src-3.0/GF/Speech/PrSLF.hs | 190 + src-3.0/GF/Speech/PrSRGS.hs | 153 + src-3.0/GF/Speech/PrSRGS_ABNF.hs | 147 + src-3.0/GF/Speech/RegExp.hs | 143 + src-3.0/GF/Speech/Relation.hs | 130 + src-3.0/GF/Speech/RelationQC.hs | 39 + src-3.0/GF/Speech/SISR.hs | 87 + src-3.0/GF/Speech/SRG.hs | 235 + src-3.0/GF/Speech/TransformCFG.hs | 378 + src-3.0/GF/System/ATKSpeechInput.hs | 137 + src-3.0/GF/System/Arch.hs | 90 + src-3.0/GF/System/ArchEdit.hs | 30 + src-3.0/GF/System/NoReadline.hs | 27 + src-3.0/GF/System/NoSignal.hs | 29 + src-3.0/GF/System/NoSpeechInput.hs | 28 + src-3.0/GF/System/Readline.hs | 27 + src-3.0/GF/System/Signal.hs | 27 + src-3.0/GF/System/SpeechInput.hs | 27 + src-3.0/GF/System/Tracing.hs | 73 + src-3.0/GF/System/UseReadline.hs | 25 + src-3.0/GF/System/UseSignal.hs | 58 + src-3.0/GF/Text/Arabic.hs | 63 + src-3.0/GF/Text/Devanagari.hs | 97 + src-3.0/GF/Text/Ethiopic.hs | 72 + src-3.0/GF/Text/ExtendedArabic.hs | 99 + src-3.0/GF/Text/ExtraDiacritics.hs | 37 + src-3.0/GF/Text/Greek.hs | 172 + src-3.0/GF/Text/Hebrew.hs | 53 + src-3.0/GF/Text/Hiragana.hs | 95 + src-3.0/GF/Text/LatinASupplement.hs | 69 + src-3.0/GF/Text/OCSCyrillic.hs | 47 + src-3.0/GF/Text/Russian.hs | 56 + src-3.0/GF/Text/Tamil.hs | 77 + src-3.0/GF/Text/Text.hs | 149 + src-3.0/GF/Text/Thai.hs | 368 + src-3.0/GF/Text/UTF8.hs | 48 + src-3.0/GF/Text/Unicode.hs | 69 + src-3.0/GF/Translate/GFT.hs | 56 + src-3.0/GF/UseGrammar/Custom.hs | 494 ++ src-3.0/GF/UseGrammar/Editing.hs | 435 ++ src-3.0/GF/UseGrammar/Generate.hs | 116 + src-3.0/GF/UseGrammar/GetTree.hs | 74 + src-3.0/GF/UseGrammar/Information.hs | 162 + src-3.0/GF/UseGrammar/Linear.hs | 292 + src-3.0/GF/UseGrammar/MatchTerm.hs | 50 + src-3.0/GF/UseGrammar/Morphology.hs | 140 + src-3.0/GF/UseGrammar/Paraphrases.hs | 70 + src-3.0/GF/UseGrammar/Parsing.hs | 177 + src-3.0/GF/UseGrammar/Randomized.hs | 66 + src-3.0/GF/UseGrammar/Session.hs | 181 + src-3.0/GF/UseGrammar/Statistics.hs | 44 + src-3.0/GF/UseGrammar/Tokenize.hs | 222 + src-3.0/GF/UseGrammar/Transfer.hs | 79 + src-3.0/GF/UseGrammar/TreeSelections.hs | 77 + src-3.0/GF/UseGrammar/Treebank.hs | 251 + src-3.0/GF/Visualization/Graphviz.hs | 116 + src-3.0/GF/Visualization/VisualizeGrammar.hs | 125 + src-3.0/GF/Visualization/VisualizeTree.hs | 58 + 399 files changed, 84123 insertions(+) create mode 100644 src-3.0/GF/API.hs create mode 100644 src-3.0/GF/API/BatchTranslate.hs create mode 100644 src-3.0/GF/API/GrammarToHaskell.hs create mode 100644 src-3.0/GF/API/GrammarToTransfer.hs create mode 100644 src-3.0/GF/API/IOGrammar.hs create mode 100644 src-3.0/GF/API/MyParser.hs create mode 100644 src-3.0/GF/CF/CF.hs create mode 100644 src-3.0/GF/CF/CFIdent.hs create mode 100644 src-3.0/GF/CF/CFtoGrammar.hs create mode 100644 src-3.0/GF/CF/CanonToCF.hs create mode 100644 src-3.0/GF/CF/ChartParser.hs create mode 100644 src-3.0/GF/CF/EBNF.hs create mode 100644 src-3.0/GF/CF/PPrCF.hs create mode 100644 src-3.0/GF/CF/PrLBNF.hs create mode 100644 src-3.0/GF/CF/Profile.hs create mode 100644 src-3.0/GF/CFGM/AbsCFG.hs create mode 100644 src-3.0/GF/CFGM/CFG.cf create mode 100644 src-3.0/GF/CFGM/LexCFG.hs create mode 100644 src-3.0/GF/CFGM/LexCFG.x create mode 100644 src-3.0/GF/CFGM/ParCFG.hs create mode 100644 src-3.0/GF/CFGM/ParCFG.y create mode 100644 src-3.0/GF/CFGM/PrintCFG.hs create mode 100644 src-3.0/GF/CFGM/PrintCFGrammar.hs create mode 100644 src-3.0/GF/Canon/AbsGFC.hs create mode 100644 src-3.0/GF/Canon/AbsToBNF.hs create mode 100644 src-3.0/GF/Canon/CMacros.hs create mode 100644 src-3.0/GF/Canon/CanonToGFCC.hs create mode 100644 src-3.0/GF/Canon/CanonToGrammar.hs create mode 100644 src-3.0/GF/Canon/GFC.cf create mode 100644 src-3.0/GF/Canon/GFC.hs create mode 100644 src-3.0/GF/Canon/GetGFC.hs create mode 100644 src-3.0/GF/Canon/LexGFC.hs create mode 100644 src-3.0/GF/Canon/LexGFC.x create mode 100644 src-3.0/GF/Canon/Look.hs create mode 100644 src-3.0/GF/Canon/MkGFC.hs create mode 100644 src-3.0/GF/Canon/ParGFC.hs create mode 100644 src-3.0/GF/Canon/ParGFC.y create mode 100644 src-3.0/GF/Canon/PrExp.hs create mode 100644 src-3.0/GF/Canon/PrintGFC.hs create mode 100644 src-3.0/GF/Canon/Share.hs create mode 100644 src-3.0/GF/Canon/SkelGFC.hs create mode 100644 src-3.0/GF/Canon/Subexpressions.hs create mode 100644 src-3.0/GF/Canon/TestGFC.hs create mode 100644 src-3.0/GF/Canon/Unlex.hs create mode 100644 src-3.0/GF/Canon/Unparametrize.hs create mode 100644 src-3.0/GF/Canon/log.txt create mode 100644 src-3.0/GF/Command/AbsGFShell.hs create mode 100644 src-3.0/GF/Command/Commands.hs create mode 100644 src-3.0/GF/Command/GFShell.cf create mode 100644 src-3.0/GF/Command/Importing.hs create mode 100644 src-3.0/GF/Command/Interpreter.hs create mode 100644 src-3.0/GF/Command/LexGFShell.hs create mode 100644 src-3.0/GF/Command/PPrTree.hs create mode 100644 src-3.0/GF/Command/ParGFShell.hs create mode 100644 src-3.0/GF/Command/PrintGFShell.hs create mode 100644 src-3.0/GF/Compile/API.hs create mode 100644 src-3.0/GF/Compile/BackOpt.hs create mode 100644 src-3.0/GF/Compile/CheckGrammar.hs create mode 100644 src-3.0/GF/Compile/Compile.hs create mode 100644 src-3.0/GF/Compile/Evaluate.hs create mode 100644 src-3.0/GF/Compile/Extend.hs create mode 100644 src-3.0/GF/Compile/Flatten.hs create mode 100644 src-3.0/GF/Compile/GetGrammar.hs create mode 100644 src-3.0/GF/Compile/GrammarToCanon.hs create mode 100644 src-3.0/GF/Compile/MkConcrete.hs create mode 100644 src-3.0/GF/Compile/MkResource.hs create mode 100644 src-3.0/GF/Compile/MkUnion.hs create mode 100644 src-3.0/GF/Compile/ModDeps.hs create mode 100644 src-3.0/GF/Compile/NewRename.hs create mode 100644 src-3.0/GF/Compile/NoParse.hs create mode 100644 src-3.0/GF/Compile/Optimize.hs create mode 100644 src-3.0/GF/Compile/PGrammar.hs create mode 100644 src-3.0/GF/Compile/PrOld.hs create mode 100644 src-3.0/GF/Compile/Rebuild.hs create mode 100644 src-3.0/GF/Compile/RemoveLiT.hs create mode 100644 src-3.0/GF/Compile/Rename.hs create mode 100644 src-3.0/GF/Compile/ShellState.hs create mode 100644 src-3.0/GF/Compile/Update.hs create mode 100644 src-3.0/GF/Compile/Wordlist.hs create mode 100644 src-3.0/GF/Conversion/GFC.hs create mode 100644 src-3.0/GF/Conversion/GFCtoSimple.hs create mode 100644 src-3.0/GF/Conversion/Haskell.hs create mode 100644 src-3.0/GF/Conversion/MCFGtoCFG.hs create mode 100644 src-3.0/GF/Conversion/MCFGtoFCFG.hs create mode 100644 src-3.0/GF/Conversion/Prolog.hs create mode 100644 src-3.0/GF/Conversion/RemoveEpsilon.hs create mode 100644 src-3.0/GF/Conversion/RemoveErasing.hs create mode 100644 src-3.0/GF/Conversion/RemoveSingletons.hs create mode 100644 src-3.0/GF/Conversion/SimpleToFCFG.hs create mode 100644 src-3.0/GF/Conversion/SimpleToFinite.hs create mode 100644 src-3.0/GF/Conversion/SimpleToMCFG.hs create mode 100644 src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs create mode 100644 src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs create mode 100644 src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs create mode 100644 src-3.0/GF/Conversion/TypeGraph.hs create mode 100644 src-3.0/GF/Conversion/Types.hs create mode 100644 src-3.0/GF/Data/Assoc.hs create mode 100644 src-3.0/GF/Data/BacktrackM.hs create mode 100644 src-3.0/GF/Data/Compos.hs create mode 100644 src-3.0/GF/Data/ErrM.hs create mode 100644 src-3.0/GF/Data/GeneralDeduction.hs create mode 100644 src-3.0/GF/Data/Glue.hs create mode 100644 src-3.0/GF/Data/IncrementalDeduction.hs create mode 100644 src-3.0/GF/Data/Map.hs create mode 100644 src-3.0/GF/Data/Operations.hs create mode 100644 src-3.0/GF/Data/OrdMap2.hs create mode 100644 src-3.0/GF/Data/OrdSet.hs create mode 100644 src-3.0/GF/Data/Parsers.hs create mode 100644 src-3.0/GF/Data/RedBlack.hs create mode 100644 src-3.0/GF/Data/RedBlackSet.hs create mode 100644 src-3.0/GF/Data/SharedString.hs create mode 100644 src-3.0/GF/Data/SortedList.hs create mode 100644 src-3.0/GF/Data/Str.hs create mode 100644 src-3.0/GF/Data/Trie.hs create mode 100644 src-3.0/GF/Data/Trie2.hs create mode 100644 src-3.0/GF/Data/Utilities.hs create mode 100644 src-3.0/GF/Data/XML.hs create mode 100644 src-3.0/GF/Data/Zipper.hs create mode 100644 src-3.0/GF/Devel/AbsCompute.hs create mode 100644 src-3.0/GF/Devel/Arch.hs create mode 100644 src-3.0/GF/Devel/CheckGrammar.hs create mode 100644 src-3.0/GF/Devel/CheckM.hs create mode 100644 src-3.0/GF/Devel/Compile.hs create mode 100644 src-3.0/GF/Devel/Compile/AbsGF.hs create mode 100644 src-3.0/GF/Devel/Compile/CheckGrammar.hs create mode 100644 src-3.0/GF/Devel/Compile/Compile.hs create mode 100644 src-3.0/GF/Devel/Compile/ErrM.hs create mode 100644 src-3.0/GF/Devel/Compile/Extend.hs create mode 100644 src-3.0/GF/Devel/Compile/Factorize.hs create mode 100644 src-3.0/GF/Devel/Compile/GF.cf create mode 100644 src-3.0/GF/Devel/Compile/GFC.hs create mode 100644 src-3.0/GF/Devel/Compile/GFtoGFCC.hs create mode 100644 src-3.0/GF/Devel/Compile/GetGrammar.hs create mode 100644 src-3.0/GF/Devel/Compile/LexGF.hs create mode 100644 src-3.0/GF/Devel/Compile/Optimize.hs create mode 100644 src-3.0/GF/Devel/Compile/ParGF.hs create mode 100644 src-3.0/GF/Devel/Compile/PrintGF.hs create mode 100644 src-3.0/GF/Devel/Compile/Refresh.hs create mode 100644 src-3.0/GF/Devel/Compile/Rename.hs create mode 100644 src-3.0/GF/Devel/Compile/SourceToGF.hs create mode 100644 src-3.0/GF/Devel/Compute.hs create mode 100644 src-3.0/GF/Devel/GF.hs create mode 100644 src-3.0/GF/Devel/GFC.hs create mode 100644 src-3.0/GF/Devel/GFC/Main.hs create mode 100644 src-3.0/GF/Devel/GFCCInterpreter.hs create mode 100644 src-3.0/GF/Devel/GFCCtoHaskell.hs create mode 100644 src-3.0/GF/Devel/GFCCtoJS.hs create mode 100644 src-3.0/GF/Devel/GFI.hs create mode 100644 src-3.0/GF/Devel/GetGrammar.hs create mode 100644 src-3.0/GF/Devel/Grammar/AppPredefined.hs create mode 100644 src-3.0/GF/Devel/Grammar/Compute.hs create mode 100644 src-3.0/GF/Devel/Grammar/Construct.hs create mode 100644 src-3.0/GF/Devel/Grammar/GFtoSource.hs create mode 100644 src-3.0/GF/Devel/Grammar/Grammar.hs create mode 100644 src-3.0/GF/Devel/Grammar/Lookup.hs create mode 100644 src-3.0/GF/Devel/Grammar/Macros.hs create mode 100644 src-3.0/GF/Devel/Grammar/PatternMatch.hs create mode 100644 src-3.0/GF/Devel/Grammar/PrGF.hs create mode 100644 src-3.0/GF/Devel/GrammarToGFCC.hs create mode 100644 src-3.0/GF/Devel/Infra/ReadFiles.hs create mode 100644 src-3.0/GF/Devel/ModDeps.hs create mode 100644 src-3.0/GF/Devel/Optimize.hs create mode 100644 src-3.0/GF/Devel/OptimizeGF.hs create mode 100644 src-3.0/GF/Devel/Options.hs create mode 100644 src-3.0/GF/Devel/PrGrammar.hs create mode 100644 src-3.0/GF/Devel/PrintGFCC.hs create mode 100644 src-3.0/GF/Devel/README-testgf3 create mode 100644 src-3.0/GF/Devel/ReadFiles.hs create mode 100644 src-3.0/GF/Devel/TC.hs create mode 100644 src-3.0/GF/Devel/TestGF3.hs create mode 100644 src-3.0/GF/Devel/TypeCheck.hs create mode 100644 src-3.0/GF/Devel/UseIO.hs create mode 100644 src-3.0/GF/Devel/gf-code.txt create mode 100644 src-3.0/GF/Devel/gf3.txt create mode 100644 src-3.0/GF/Embed/EmbedAPI.hs create mode 100644 src-3.0/GF/Embed/EmbedCustom.hs create mode 100644 src-3.0/GF/Embed/EmbedParsing.hs create mode 100644 src-3.0/GF/Embed/TemplateApp.hs create mode 100644 src-3.0/GF/Formalism/CFG.hs create mode 100644 src-3.0/GF/Formalism/FCFG.hs create mode 100644 src-3.0/GF/Formalism/GCFG.hs create mode 100644 src-3.0/GF/Formalism/MCFG.hs create mode 100644 src-3.0/GF/Formalism/SimpleGFC.hs create mode 100644 src-3.0/GF/Formalism/Utilities.hs create mode 100644 src-3.0/GF/Fudgets/ArchEdit.hs create mode 100644 src-3.0/GF/Fudgets/CommandF.hs create mode 100644 src-3.0/GF/Fudgets/EventF.hs create mode 100644 src-3.0/GF/Fudgets/FudgetOps.hs create mode 100644 src-3.0/GF/Fudgets/UnicodeF.hs create mode 100644 src-3.0/GF/GFCC/API.hs create mode 100644 src-3.0/GF/GFCC/CId.hs create mode 100644 src-3.0/GF/GFCC/CheckGFCC.hs create mode 100644 src-3.0/GF/GFCC/ComposOp.hs create mode 100644 src-3.0/GF/GFCC/DataGFCC.hs create mode 100644 src-3.0/GF/GFCC/GFCC.cf create mode 100644 src-3.0/GF/GFCC/Generate.hs create mode 100644 src-3.0/GF/GFCC/LexGFCC.hs create mode 100644 src-3.0/GF/GFCC/Linearize.hs create mode 100644 src-3.0/GF/GFCC/Macros.hs create mode 100644 src-3.0/GF/GFCC/OptimizeGFCC.hs create mode 100644 src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs create mode 100644 src-3.0/GF/GFCC/Raw/ConvertGFCC.hs create mode 100644 src-3.0/GF/GFCC/Raw/GFCCRaw.cf create mode 100644 src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs create mode 100644 src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs create mode 100644 src-3.0/GF/GFCC/ShowLinearize.hs create mode 100644 src-3.0/GF/GFCC/SkelGFCC.hs create mode 100644 src-3.0/GF/GFCC/TestGFCC.hs create mode 100644 src-3.0/GF/GFCC/doc/Eng.gf create mode 100644 src-3.0/GF/GFCC/doc/Ex.gf create mode 100644 src-3.0/GF/GFCC/doc/Swe.gf create mode 100644 src-3.0/GF/GFCC/doc/Test.gf create mode 100644 src-3.0/GF/GFCC/doc/gfcc.html create mode 100644 src-3.0/GF/GFCC/doc/gfcc.txt create mode 100644 src-3.0/GF/GFCC/doc/old-GFCC.cf create mode 100644 src-3.0/GF/GFCC/doc/old-gfcc.txt create mode 100644 src-3.0/GF/GFCC/doc/syntax.txt create mode 100644 src-3.0/GF/GFModes.hs create mode 100644 src-3.0/GF/Grammar/AbsCompute.hs create mode 100644 src-3.0/GF/Grammar/Abstract.hs create mode 100644 src-3.0/GF/Grammar/AppPredefined.hs create mode 100644 src-3.0/GF/Grammar/Compute.hs create mode 100644 src-3.0/GF/Grammar/Grammar.hs create mode 100644 src-3.0/GF/Grammar/Lockfield.hs create mode 100644 src-3.0/GF/Grammar/LookAbs.hs create mode 100644 src-3.0/GF/Grammar/Lookup.hs create mode 100644 src-3.0/GF/Grammar/MMacros.hs create mode 100644 src-3.0/GF/Grammar/Macros.hs create mode 100644 src-3.0/GF/Grammar/PatternMatch.hs create mode 100644 src-3.0/GF/Grammar/PrGrammar.hs create mode 100644 src-3.0/GF/Grammar/Refresh.hs create mode 100644 src-3.0/GF/Grammar/ReservedWords.hs create mode 100644 src-3.0/GF/Grammar/SGrammar.hs create mode 100644 src-3.0/GF/Grammar/TC.hs create mode 100644 src-3.0/GF/Grammar/TypeCheck.hs create mode 100644 src-3.0/GF/Grammar/Unify.hs create mode 100644 src-3.0/GF/Grammar/Values.hs create mode 100644 src-3.0/GF/IDE/IDECommands.hs create mode 100644 src-3.0/GF/Infra/CheckM.hs create mode 100644 src-3.0/GF/Infra/Comments.hs create mode 100644 src-3.0/GF/Infra/CompactPrint.hs create mode 100644 src-3.0/GF/Infra/Ident.hs create mode 100644 src-3.0/GF/Infra/Modules.hs create mode 100644 src-3.0/GF/Infra/Option.hs create mode 100644 src-3.0/GF/Infra/Print.hs create mode 100644 src-3.0/GF/Infra/PrintClass.hs create mode 100644 src-3.0/GF/Infra/ReadFiles.hs create mode 100644 src-3.0/GF/Infra/UseIO.hs create mode 100644 src-3.0/GF/JavaScript/AbsJS.hs create mode 100644 src-3.0/GF/JavaScript/JS.cf create mode 100644 src-3.0/GF/JavaScript/LexJS.hs create mode 100644 src-3.0/GF/JavaScript/LexJS.x create mode 100644 src-3.0/GF/JavaScript/Makefile create mode 100644 src-3.0/GF/JavaScript/ParJS.hs create mode 100644 src-3.0/GF/JavaScript/ParJS.y create mode 100644 src-3.0/GF/JavaScript/PrintJS.hs create mode 100644 src-3.0/GF/JavaScript/SkelJS.hs create mode 100644 src-3.0/GF/JavaScript/TestJS.hs create mode 100644 src-3.0/GF/OldParsing/CFGrammar.hs create mode 100644 src-3.0/GF/OldParsing/ConvertFiniteGFC.hs create mode 100644 src-3.0/GF/OldParsing/ConvertFiniteSimple.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs create mode 100644 src-3.0/GF/OldParsing/ConvertGrammar.hs create mode 100644 src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs create mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs create mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs create mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs create mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs create mode 100644 src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs create mode 100644 src-3.0/GF/OldParsing/GCFG.hs create mode 100644 src-3.0/GF/OldParsing/GeneralChart.hs create mode 100644 src-3.0/GF/OldParsing/GrammarTypes.hs create mode 100644 src-3.0/GF/OldParsing/IncrementalChart.hs create mode 100644 src-3.0/GF/OldParsing/MCFGrammar.hs create mode 100644 src-3.0/GF/OldParsing/ParseCF.hs create mode 100644 src-3.0/GF/OldParsing/ParseCFG.hs create mode 100644 src-3.0/GF/OldParsing/ParseCFG/General.hs create mode 100644 src-3.0/GF/OldParsing/ParseCFG/Incremental.hs create mode 100644 src-3.0/GF/OldParsing/ParseGFC.hs create mode 100644 src-3.0/GF/OldParsing/ParseMCFG.hs create mode 100644 src-3.0/GF/OldParsing/ParseMCFG/Basic.hs create mode 100644 src-3.0/GF/OldParsing/SimpleGFC.hs create mode 100644 src-3.0/GF/OldParsing/Utilities.hs create mode 100644 src-3.0/GF/Parsing/CF.hs create mode 100644 src-3.0/GF/Parsing/CFG.hs create mode 100644 src-3.0/GF/Parsing/CFG/General.hs create mode 100644 src-3.0/GF/Parsing/CFG/Incremental.hs create mode 100644 src-3.0/GF/Parsing/CFG/PInfo.hs create mode 100644 src-3.0/GF/Parsing/FCFG.hs create mode 100644 src-3.0/GF/Parsing/FCFG/Active.hs create mode 100644 src-3.0/GF/Parsing/FCFG/Incremental.hs create mode 100644 src-3.0/GF/Parsing/FCFG/PInfo.hs create mode 100644 src-3.0/GF/Parsing/FCFG/Range.hs create mode 100644 src-3.0/GF/Parsing/GFC.hs create mode 100644 src-3.0/GF/Parsing/MCFG.hs create mode 100644 src-3.0/GF/Parsing/MCFG/Active.hs create mode 100644 src-3.0/GF/Parsing/MCFG/Active2.hs create mode 100644 src-3.0/GF/Parsing/MCFG/FastActive.hs create mode 100644 src-3.0/GF/Parsing/MCFG/Incremental.hs create mode 100644 src-3.0/GF/Parsing/MCFG/Incremental2.hs create mode 100644 src-3.0/GF/Parsing/MCFG/Naive.hs create mode 100644 src-3.0/GF/Parsing/MCFG/PInfo.hs create mode 100644 src-3.0/GF/Parsing/MCFG/Range.hs create mode 100644 src-3.0/GF/Parsing/MCFG/ViaCFG.hs create mode 100644 src-3.0/GF/Printing/PrintParser.hs create mode 100644 src-3.0/GF/Printing/PrintSimplifiedTerm.hs create mode 100644 src-3.0/GF/Probabilistic/Probabilistic.hs create mode 100644 src-3.0/GF/Shell.hs create mode 100644 src-3.0/GF/Shell/CommandL.hs create mode 100644 src-3.0/GF/Shell/Commands.hs create mode 100644 src-3.0/GF/Shell/HelpFile.hs create mode 100644 src-3.0/GF/Shell/JGF.hs create mode 100644 src-3.0/GF/Shell/PShell.hs create mode 100644 src-3.0/GF/Shell/ShellCommands.hs create mode 100644 src-3.0/GF/Shell/SubShell.hs create mode 100644 src-3.0/GF/Shell/TeachYourself.hs create mode 100644 src-3.0/GF/Source/AbsGF.hs create mode 100644 src-3.0/GF/Source/ErrM.hs create mode 100644 src-3.0/GF/Source/GF.cf create mode 100644 src-3.0/GF/Source/GrammarToSource.hs create mode 100644 src-3.0/GF/Source/LexGF.hs create mode 100644 src-3.0/GF/Source/LexGF.x create mode 100644 src-3.0/GF/Source/ParGF.hs create mode 100644 src-3.0/GF/Source/ParGF.y create mode 100644 src-3.0/GF/Source/PrintGF.hs create mode 100644 src-3.0/GF/Source/SkelGF.hs create mode 100644 src-3.0/GF/Source/SourceToGrammar.hs create mode 100644 src-3.0/GF/Source/TestGF.hs create mode 100644 src-3.0/GF/Speech/CFGToFiniteState.hs create mode 100644 src-3.0/GF/Speech/FiniteState.hs create mode 100644 src-3.0/GF/Speech/GrammarToVoiceXML.hs create mode 100644 src-3.0/GF/Speech/Graph.hs create mode 100644 src-3.0/GF/Speech/PrFA.hs create mode 100644 src-3.0/GF/Speech/PrGSL.hs create mode 100644 src-3.0/GF/Speech/PrJSGF.hs create mode 100644 src-3.0/GF/Speech/PrRegExp.hs create mode 100644 src-3.0/GF/Speech/PrSLF.hs create mode 100644 src-3.0/GF/Speech/PrSRGS.hs create mode 100644 src-3.0/GF/Speech/PrSRGS_ABNF.hs create mode 100644 src-3.0/GF/Speech/RegExp.hs create mode 100644 src-3.0/GF/Speech/Relation.hs create mode 100644 src-3.0/GF/Speech/RelationQC.hs create mode 100644 src-3.0/GF/Speech/SISR.hs create mode 100644 src-3.0/GF/Speech/SRG.hs create mode 100644 src-3.0/GF/Speech/TransformCFG.hs create mode 100644 src-3.0/GF/System/ATKSpeechInput.hs create mode 100644 src-3.0/GF/System/Arch.hs create mode 100644 src-3.0/GF/System/ArchEdit.hs create mode 100644 src-3.0/GF/System/NoReadline.hs create mode 100644 src-3.0/GF/System/NoSignal.hs create mode 100644 src-3.0/GF/System/NoSpeechInput.hs create mode 100644 src-3.0/GF/System/Readline.hs create mode 100644 src-3.0/GF/System/Signal.hs create mode 100644 src-3.0/GF/System/SpeechInput.hs create mode 100644 src-3.0/GF/System/Tracing.hs create mode 100644 src-3.0/GF/System/UseReadline.hs create mode 100644 src-3.0/GF/System/UseSignal.hs create mode 100644 src-3.0/GF/Text/Arabic.hs create mode 100644 src-3.0/GF/Text/Devanagari.hs create mode 100644 src-3.0/GF/Text/Ethiopic.hs create mode 100644 src-3.0/GF/Text/ExtendedArabic.hs create mode 100644 src-3.0/GF/Text/ExtraDiacritics.hs create mode 100644 src-3.0/GF/Text/Greek.hs create mode 100644 src-3.0/GF/Text/Hebrew.hs create mode 100644 src-3.0/GF/Text/Hiragana.hs create mode 100644 src-3.0/GF/Text/LatinASupplement.hs create mode 100644 src-3.0/GF/Text/OCSCyrillic.hs create mode 100644 src-3.0/GF/Text/Russian.hs create mode 100644 src-3.0/GF/Text/Tamil.hs create mode 100644 src-3.0/GF/Text/Text.hs create mode 100644 src-3.0/GF/Text/Thai.hs create mode 100644 src-3.0/GF/Text/UTF8.hs create mode 100644 src-3.0/GF/Text/Unicode.hs create mode 100644 src-3.0/GF/Translate/GFT.hs create mode 100644 src-3.0/GF/UseGrammar/Custom.hs create mode 100644 src-3.0/GF/UseGrammar/Editing.hs create mode 100644 src-3.0/GF/UseGrammar/Generate.hs create mode 100644 src-3.0/GF/UseGrammar/GetTree.hs create mode 100644 src-3.0/GF/UseGrammar/Information.hs create mode 100644 src-3.0/GF/UseGrammar/Linear.hs create mode 100644 src-3.0/GF/UseGrammar/MatchTerm.hs create mode 100644 src-3.0/GF/UseGrammar/Morphology.hs create mode 100644 src-3.0/GF/UseGrammar/Paraphrases.hs create mode 100644 src-3.0/GF/UseGrammar/Parsing.hs create mode 100644 src-3.0/GF/UseGrammar/Randomized.hs create mode 100644 src-3.0/GF/UseGrammar/Session.hs create mode 100644 src-3.0/GF/UseGrammar/Statistics.hs create mode 100644 src-3.0/GF/UseGrammar/Tokenize.hs create mode 100644 src-3.0/GF/UseGrammar/Transfer.hs create mode 100644 src-3.0/GF/UseGrammar/TreeSelections.hs create mode 100644 src-3.0/GF/UseGrammar/Treebank.hs create mode 100644 src-3.0/GF/Visualization/Graphviz.hs create mode 100644 src-3.0/GF/Visualization/VisualizeGrammar.hs create mode 100644 src-3.0/GF/Visualization/VisualizeTree.hs (limited to 'src-3.0/GF') diff --git a/src-3.0/GF/API.hs b/src-3.0/GF/API.hs new file mode 100644 index 000000000..b1deeddfc --- /dev/null +++ b/src-3.0/GF/API.hs @@ -0,0 +1,472 @@ +---------------------------------------------------------------------- +-- | +-- Module : API +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:40 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.39 $ +-- +-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001 +----------------------------------------------------------------------------- + +module GF.API where + +import qualified GF.Source.AbsGF as GF +import qualified GF.Canon.AbsGFC as A +import qualified GF.Compile.Rename as R +import GF.UseGrammar.GetTree +import GF.Canon.GFC +--- import qualified Values as V +import GF.Grammar.Values + +-----import GetGrammar +import GF.Compile.Compile +import GF.API.IOGrammar +import GF.UseGrammar.Linear +import GF.UseGrammar.Parsing +import GF.UseGrammar.Morphology +import GF.CF.PPrCF +import GF.CF.CFIdent +import GF.Compile.PGrammar +import GF.UseGrammar.Randomized (mkRandomTree) + +import GF.Grammar.MMacros +import qualified GF.Grammar.Macros as M +import GF.Grammar.TypeCheck +import GF.Canon.CMacros +import GF.UseGrammar.Transfer +import qualified GF.UseGrammar.Generate as Gen + +import GF.Text.Text (untokWithXML) +import GF.Infra.Option +import GF.UseGrammar.Custom +import GF.Compile.ShellState +import GF.UseGrammar.Linear +import GF.Canon.GFC +import qualified GF.Grammar.Grammar as G +import GF.Infra.Modules +import GF.Grammar.PrGrammar +import qualified GF.Grammar.Compute as Co +import qualified GF.Grammar.AbsCompute as AC +import qualified GF.Infra.Ident as I +import qualified GF.Compile.GrammarToCanon as GC +import qualified GF.Canon.CanonToGrammar as CG +import qualified GF.Canon.MkGFC as MC +import qualified GF.Embed.EmbedAPI as EA + +import GF.UseGrammar.Editing + +import GF.System.SpeechInput (recognizeSpeech) + +----import GrammarToXML + +----import GrammarToMGrammar as M + +import qualified Transfer.InterpreterAPI as T + +import GF.System.Arch (myStdGen) + +import GF.Text.UTF8 +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Data.Zipper + +import Data.List (nub) +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Monad (liftM) +import System (system) +import System.FilePath + +type GFGrammar = StateGrammar +type GFCat = CFCat +type Ident = I.Ident +--- type Tree = V.Tree + +-- these are enough for many simple applications + +file2grammar :: FilePath -> IO GFGrammar +file2grammar file = do + egr <- appIOE $ optFile2grammar (iOpts [beSilent]) file + err (\s -> putStrLn s >> return emptyStateGrammar) return egr + +linearize :: GFGrammar -> Tree -> String +linearize sgr = err id id . optLinearizeTree opts sgr where + opts = addOption firstLin $ stateOptions sgr + +term2tree :: GFGrammar -> G.Term -> Tree +term2tree gr = errVal uTree . annotate (grammar gr) . qualifTerm (absId gr) + +tree2term :: Tree -> G.Term +tree2term = tree2exp + +linearizeToAll :: [GFGrammar] -> Tree -> [String] +linearizeToAll grs t = [linearize gr t | gr <- grs] + +parse :: GFGrammar -> GFCat -> String -> [Tree] +parse sgr cat = errVal [] . parseString noOptions sgr cat + +parseAny :: [GFGrammar] -> GFCat -> String -> [Tree] +parseAny grs cat s = + concat [errVal [] (parseString (options [iOpt "trynextlang"]) gr cat s) | gr <- grs] + +translate :: GFGrammar -> GFGrammar -> GFCat -> String -> [String] +translate ig og cat = map (linearize og) . parse ig cat + +translateToAll :: GFGrammar -> [GFGrammar] -> GFCat -> String -> [String] +translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat + +translateFromAny :: [GFGrammar] -> GFGrammar -> GFCat -> String -> [String] +translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs] + +translateBetweenAll :: [GFGrammar] -> GFCat -> String -> [String] +translateBetweenAll grs cat = + concat . map (linearizeToAll grs) . parseAny grs cat + +homonyms :: GFGrammar -> GFCat -> Tree -> [Tree] +homonyms gr cat = nub . parse gr cat . linearize gr + +hasAmbiguousLin :: GFGrammar -> GFCat -> Tree -> Bool +hasAmbiguousLin gr cat t = case (homonyms gr cat t) of + _:_:_ -> True + _ -> False + +{- ---- +-- returns printname if one exists; othewrise linearizes with metas +printOrLin :: GFGrammar -> Fun -> String +printOrLin gr = printOrLinearize (stateGrammarST gr) + +-- reads a syntax file and writes it in a format wanted +transformGrammarFile :: Options -> FilePath -> IO String +transformGrammarFile opts file = do + sy <- useIOE GF.emptySyntax $ getSyntax opts file + return $ optPrintSyntax opts sy +-} + +prIdent :: Ident -> String +prIdent = prt + +string2GFCat :: String -> String -> GFCat +string2GFCat = string2CFCat + +-- then stg for customizable and internal use + +optFile2grammar :: Options -> FilePath -> IOE GFGrammar +optFile2grammar os f + | takeExtensions f == ".gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f + | otherwise = do + ((_,_,gr,_),_) <- compileModule os emptyShellState f + ioeErr $ grammar2stateGrammar os gr + +optFile2grammarE :: Options -> FilePath -> IOE GFGrammar +optFile2grammarE = optFile2grammar + + +string2treeInState :: GFGrammar -> String -> State -> Err Tree +string2treeInState gr s st = do + let metas = allMetas st + xs = map fst $ actBinds st + t0 <- pTerm s + let t = qualifTerm (absId gr) $ M.mkAbs xs $ refreshMetas metas $ t0 + annotateExpInState (grammar gr) t st + +string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term +string2srcTerm gr m s = do + t <- pTerm s + R.renameSourceTerm gr m t + +randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree] +randomTreesIO opts gr n = do + gen <- myStdGen mx + t <- err (\s -> putS s >> return []) + (return . singleton) $ + mkRandomTree gen mx g catfun + ts <- if n==1 then return [] else randomTreesIO opts gr (n-1) + return $ t ++ ts + where + catfun = case getOptVal opts withFun of + Just fun -> Right $ (absId gr, I.identC fun) + _ -> Left $ firstAbsCat opts gr + g = grammar gr + mx = optIntOrN opts flagDepth 41 + putS s = if oElem beSilent opts then return () else putStrLnFlush s + + +generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree] +generateTrees opts gr mt = + optIntOrAll opts flagNumber + [tr | t <- Gen.generateTrees opts gr' cat dpt mn mt, Ok tr <- [mkTr t]] + where + mkTr = annotate gr' . qualifTerm (absId gr) + gr' = grammar gr + cat = firstAbsCat opts gr + dpt = maybe 3 id $ getOptInt opts flagDepth + mn = getOptInt opts flagAlts + +speechGenerate :: Options -> String -> IO () +speechGenerate opts str = do + let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage + system ("flite" +++ "\" " ++ str ++ "\"") +--- system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan) + return () + +speechInput :: Options -> StateGrammar -> IO [String] +speechInput opt s = recognizeSpeech name language cfg cat number + where + opts = addOptions opt (stateOptions s) + name = cncId s + cfg = stateCFG s -- FIXME: use lang flag to select grammar + language = fromMaybe "en_UK" (getOptVal opts speechLanguage) + cat = prCFCat (firstCatOpts opts s) ++ "{}.s" + number = optIntOrN opts flagNumber 1 + +optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String +optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr + +optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String +optLinearizeTree opts0 gr t = case getOptVal opts transferFun of + Just m -> useByTransfer flin g (I.identC m) t + _ -> flin t + where + opts = addOptions opts0 (stateOptions gr) + flin = case getOptVal opts markLin of + Just mk + | mk == markOptXML -> lin markXML + | mk == markOptJava -> lin markXMLjgf + | mk == markOptStruct -> lin markBracket + | mk == markOptFocus -> lin markFocus + | mk == "metacat" -> lin metaCatMark + | otherwise -> lin noMark + _ -> lin noMark + + lin mk + | oElem showRecord opts = liftM prt . linearizeNoMark g c + | oElem tableLin opts = liftM (unlines . map untok . prLinTable True) . + allLinTables True g c + | oElem showFields opts = liftM (unlines . map untok) . + allLinBranchFields g c + | oElem showAll opts = liftM (unlines . map untok . prLinTable False) . + allLinTables False g c + | otherwise = return . unlines . map untok . optIntOrOne . linTree2strings mk g c + g = grammar gr + c = cncId gr + untok = if False ---- oElem (markLin markOptXML) opts + then untokWithXML unt + else unt + unt = customOrDefault opts useUntokenizer customUntokenizer gr + optIntOrOne = take $ optIntOrN opts flagNumber 1 + +{- ---- + untoksl . lin where + gr = concreteOf (stateGrammarST sgr) + lin -- options mutually exclusive, with priority: struct, rec, table, one + | oElem showStruct opts = markedLinString True gr . tree2loc + | oElem showRecord opts = err id prt . linTerm gr + | oElem tableLin opts = err id (concatMap prLinTable) . allLinsAsStrs gr + | oElem firstLin opts = unlines . map sstr . take 1 . allLinStrings gr + | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr + untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr + opts' = addOptions opts $ stateOptions sgr + untoksl = unlines . map untoks . lines +-} + +{- +optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String +optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where + gr = concreteOf (stateGrammarST sgr) + ts = annotateTrm sgr ts0 + ms = map (renameTrm (lookupConcrete gr)) fs + lin -- options mutually exclusive, with priority: struct, rec, table + | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms + | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms + tkStrs = concat . map snd . concat . map snd + untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr + opts' = addOptions opts $ stateOptions sgr + untoksl = unlines . map untoks . lines +-} + +optParseArg :: Options -> GFGrammar -> String -> [Tree] +optParseArg opts gr = err (const []) id . optParseArgErr opts gr + +optParseArgAny :: Options -> [GFGrammar] -> String -> [Tree] +optParseArgAny opts grs s = concat [pars gr s | gr <- grs] where + pars gr = optParseArg opts gr --- grammar options! + +optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree] +optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr + +optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String) +optParseArgErrMsg opts gr s = do + let cat = firstCatOpts opts gr + g = grammar gr + (ts,m) <- parseStringMsg opts gr cat s + ts' <- case getOptVal opts transferFun of + Just m -> mkByTransfer (const $ return ts) g (I.identC m) s + _ -> return ts + return (ts',m) + +-- | analyses word by word +morphoAnalyse :: Options -> GFGrammar -> String -> String +morphoAnalyse opts gr + | oElem (iOpt "status") opts = morphoTextStatus mo + | oElem beShort opts = morphoTextShort mo + | otherwise = morphoText mo + where + mo = morpho gr + +isKnownWord :: GFGrammar -> String -> Bool +isKnownWord gr s = GF.UseGrammar.Morphology.isKnownWord (morpho gr) s + +unknownTokens :: GFGrammar -> [CFTok] -> [String] +unknownTokens gr ts = + [w | TC w <- ts, unk w && unk (uncap w)] ++ [w | TS w <- ts, unk w] + where + unk w = not $ GF.API.isKnownWord gr w + uncap (c:cs) = toLower c : cs + uncap s = s + + +{- +prExpXML :: StateGrammar -> Term -> [String] +prExpXML gr = prElementX . term2elemx (stateAbstract gr) + +prMultiGrammar :: Options -> ShellState -> String +prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts) +-} +-- access to customizable commands + +optPrintGrammar :: Options -> StateGrammar -> String +optPrintGrammar opts = pg opts + where + pg = customOrDefault opts grammarPrinter customGrammarPrinter + +optPrintMultiGrammar :: Options -> CanonGrammar -> String +optPrintMultiGrammar opts = encodeId . pmg opts . encode + where + pmg = customOrDefault opts grammarPrinter customMultiGrammarPrinter + -- if -utf8 was given, convert from language specific codings + encode = if oElem useUTF8 opts then mapModules moduleToUTF8 else id + -- if -utf8id was given, convert non-literals to UTF8 + encodeId = if oElem useUTF8id opts then nonLiteralsToUTF8 else id + moduleToUTF8 m = + m{ jments = mapTree (onSnd (mapInfoTerms code)) (jments m), + flags = setFlag "coding" "utf8" (flags m) } + where code = onTokens (anyCodingToUTF8 (moduleOpts m)) + moduleOpts = Opts . okError . mapM CG.redFlag . flags + +optPrintSyntax :: Options -> GF.Grammar -> String +optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter + +optPrintTree :: Options -> GFGrammar -> Tree -> String +optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter + +-- | look for string command (-filter=x) +optStringCommand :: Options -> GFGrammar -> String -> String +optStringCommand opts g = + optIntOrAll opts flagLength . + customOrDefault opts filterString customStringCommand g + +optTermCommand :: Options -> GFGrammar -> Tree -> [Tree] +optTermCommand opts st = + optIntOrAll opts flagNumber . + customOrDefault opts termCommand customTermCommand st + + +-- wraps term in a function and optionally computes the result + +wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree +wrapByFun opts gr f t = + if oElem doCompute opts + then err (const t) id $ AC.computeAbsTerm (grammar gr) t' >>= annotate g + else err (const t) id $ annotate g t' + where + t' = qualifTerm (absId gr) $ M.appCons f [tree2exp t] + g = grammar gr + +applyTransfer :: Options -> GFGrammar -> [(Ident,T.Env)] -> + (Maybe Ident,Ident) -> Tree -> Err [Tree] +applyTransfer opts gr trs (mm,f) t = mapM (annotate g) ts' + where + ts' = map (qualifTerm (absId gr)) $ trans tr f $ tree2exp t + g = grammar gr + tr = case mm of + Just m -> maybe empty id $ lookup m trs + _ -> ifNull empty (snd . head) trs + -- FIXME: if the returned value is a list, + -- return a list of trees + trans :: T.Env -> Ident -> Exp -> [Exp] + trans tr f = (:[]) . core2exp . T.evaluateExp tr . exp2core f + empty = T.builtin + +{- +optTransfer :: Options -> StateGrammar -> G.Term -> G.Term +optTransfer opts g = case getOptVal opts transferFun of + Just f -> wrapByFun (addOption doCompute opts) g (M.zIdent f) + _ -> id +-} + +optTokenizerResult :: Options -> GFGrammar -> String -> [[CFTok]] +optTokenizerResult opts gr = customOrDefault opts useTokenizer customTokenizer gr + +optTokenizer :: Options -> GFGrammar -> String -> String +optTokenizer opts gr = show . optTokenizerResult opts gr + +-- performs UTF8 if the language does not have flag coding=utf8; replaces name*U + +-- | convert a Unicode string into a UTF8 encoded string +optEncodeUTF8 :: GFGrammar -> String -> String +optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of + Just "utf8" -> id + _ -> encodeUTF8 + +-- | convert a UTF8 encoded string into a Unicode string +optDecodeUTF8 :: GFGrammar -> String -> String +optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of + Just "utf8" -> decodeUTF8 + _ -> id + +-- | convert a string encoded with some coding given by the coding flag to UTF8 +anyCodingToUTF8 :: Options -> String -> String +anyCodingToUTF8 opts = + encodeUTF8 . customOrDefault opts uniCoding customUniCoding + + +-- | Convert all text not inside double quotes to UTF8 +nonLiteralsToUTF8 :: String -> String +nonLiteralsToUTF8 "" = "" +nonLiteralsToUTF8 ('"':cs) = '"' : l ++ nonLiteralsToUTF8 rs + where + (l,rs) = takeStringLit cs + -- | Split off an initial string ended by double quotes + takeStringLit :: String -> (String,String) + takeStringLit "" = ("","") + takeStringLit ('"':cs) = (['"'],cs) + takeStringLit ('\\':'"':cs) = ('\\':'"':xs,ys) + where (xs,ys) = takeStringLit cs + takeStringLit (c:cs) = (c:xs,ys) + where (xs,ys) = takeStringLit cs +nonLiteralsToUTF8 (c:cs) = encodeUTF8 [c] ++ nonLiteralsToUTF8 cs + + +printParadigm :: G.Term -> String +printParadigm term = + if hasTable term then + (unlines . map prBranch . branches . head . tables) term + else + prt term + where + tables t = case t of + G.R rs -> concatMap (tables . snd . snd) rs + G.T _ cs -> [cs] + _ -> [] + hasTable t = not $ null $ tables t + branches cs = [(p:ps,s) | + (p,t) <- cs, + let ts = tables t, + (ps,s) <- if null ts then [([],t)] + else concatMap branches ts + ] + prBranch (ps,s) = unwords (map prt ps ++ [prt s]) diff --git a/src-3.0/GF/API/BatchTranslate.hs b/src-3.0/GF/API/BatchTranslate.hs new file mode 100644 index 000000000..c1b124526 --- /dev/null +++ b/src-3.0/GF/API/BatchTranslate.hs @@ -0,0 +1,43 @@ +---------------------------------------------------------------------- +-- | +-- Module : BatchTranslate +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:05 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- translate OCL, etc, files in batch mode +----------------------------------------------------------------------------- + +module GF.API.BatchTranslate (translate) where + +import GF.API +import GetMyTree (file2tree) + +translate :: FilePath -> FilePath -> IO () +translate fgr txt = do + gr <- file2grammar fgr + s <- file2tree txt + putStrLn $ linearize gr s + + +{- headers for model-specific grammars: + +abstract userDefined = oclLibrary ** { + +--# -path=.:abstract:prelude:English:ExtraEng +concrete userDefinedEng of userDefined = oclLibraryEng ** open externalOperEng in { + +--# -path=.:abstract:prelude:German:ExtraGer +concrete userDefinedGer of userDefined = oclLibraryGer ** open +externalOperGer in { + + +It seems we should add open + + ParadigmsX, ResourceExtX, PredicationX + +-} diff --git a/src-3.0/GF/API/GrammarToHaskell.hs b/src-3.0/GF/API/GrammarToHaskell.hs new file mode 100644 index 000000000..c57cfed42 --- /dev/null +++ b/src-3.0/GF/API/GrammarToHaskell.hs @@ -0,0 +1,271 @@ +---------------------------------------------------------------------- +-- | +-- Module : GrammarToHaskell +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 12:39:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- to write a GF abstract grammar into a Haskell module with translations from +-- data objects into GF trees. Example: GSyntax for Agda. +-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 +----------------------------------------------------------------------------- + +module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where + +import qualified GF.Canon.GFC as GFC +import GF.Grammar.Macros + +import GF.Infra.Modules +import GF.Data.Operations + +import Data.List (isPrefixOf, find, intersperse) +import Data.Maybe (fromMaybe) + +-- | the main function +grammar2haskell :: GFC.CanonGrammar -> String +grammar2haskell gr = foldr (++++) [] $ + haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr'] + where gr' = hSkeleton gr + +grammar2haskellGADT :: GFC.CanonGrammar -> String +grammar2haskellGADT gr = foldr (++++) [] $ + ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ + haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT gr', + gfinstances gr', fginstances gr'] + where gr' = hSkeleton gr + +-- | by this you can prefix all identifiers with stg; the default is 'G' +gId :: OIdent -> OIdent +gId i = 'G':i + +haskPreamble = + [ + "module GSyntax where", + "", + "import GF.Infra.Ident", + "import GF.Grammar.Grammar", + "import GF.Grammar.PrGrammar", + "import GF.Grammar.Macros", + "import GF.Data.Compos", + "import GF.Data.Operations", + "", + "import Control.Applicative (pure,(<*>))", + "import Data.Traversable (traverse)", + "----------------------------------------------------", + "-- automatic translation from GF to Haskell", + "----------------------------------------------------", + "", + "class Gf a where gf :: a -> Trm", + "class Fg a where fg :: Trm -> a", + "", + predefInst "GString" "String" "K s", + "", + predefInst "GInt" "Integer" "EInt s", + "", + predefInst "GFloat" "Double" "EFloat s", + "", + "----------------------------------------------------", + "-- below this line machine-generated", + "----------------------------------------------------", + "" + ] + +predefInst gtyp typ patt = + "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ + "instance Gf" +++ gtyp +++ "where" ++++ + " gf (" ++ gtyp +++ "s) =" +++ patt +++++ + "instance Fg" +++ gtyp +++ "where" ++++ + " fg t =" ++++ + " case termForm t of" ++++ + " Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++ + " _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)" + +type OIdent = String + +type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] + +datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String +datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd +gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g +fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g + +hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String +hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String + +hDatatype ("Cn",_) = "" --- +hDatatype (cat,[]) = "" +hDatatype (cat,rules) | isListCat (cat,rules) = + "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" + +++ "deriving Show" +hDatatype (cat,rules) = + "data" +++ gId cat +++ "=" ++ + (if length rules == 1 then "" else "\n ") +++ + foldr1 (\x y -> x ++ "\n |" +++ y) + [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++ + " deriving Show" + +-- GADT version of data types +datatypesGADT :: (String,HSkeleton) -> String +datatypesGADT (_,skel) = + unlines (concatMap hCatTypeGADT skel) + +++++ + "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel) + +hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] +hCatTypeGADT (cat,rules) + = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", + "data"+++gId cat++"_"] + +hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] +hDatatypeGADT (cat, rules) + | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] + | otherwise = + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] + where t = "Tree" +++ gId cat ++ "_" + + +----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 +hInstance m (cat,[]) = "" +hInstance m (cat,rules) + | isListCat (cat,rules) = + "instance Gf" +++ gId cat +++ "where" ++++ + " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" + +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ + " gf (" ++ gId cat +++ "(x:xs)) = " + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] +-- no show for GADTs +-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" + | otherwise = + "instance Gf" +++ gId cat +++ "where" ++ + (if length rules == 1 then "" else "\n") +++ + foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules] + where + ec = elemCat cat + baseVars = mkVars (baseSize (cat,rules)) + mkInst f xx = let xx' = mkVars (length xx) in "gf " ++ + (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ + "=" +++ mkRHS f xx' + mkVars n = ["x" ++ show i | i <- [1..n]] + mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + + +----fInstance m ("Cn",_) = "" --- +fInstance m (cat,[]) = "" +fInstance m (cat,rules) = + "instance Fg" +++ gId cat +++ "where" ++++ + " fg t =" ++++ + " case termForm t of" ++++ + foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++ + " _ -> error (\"no" +++ cat ++ " \" ++ prt t)" + where + mkInst f xx = + " Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++ + "[" ++ prTList "," xx' ++ "])" +++ + "->" +++ mkRHS f xx' + where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + mkRHS f vars + | isListCat (cat,rules) = + if "Base" `isPrefixOf` f then + gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" + else + let (i,t) = (init vars,last vars) + in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ + gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) + | otherwise = + gId f +++ + prTList " " [prParenth ("fg" +++ x) | x <- vars] + +composInstance :: (String,HSkeleton) -> String +composInstance (_,skel) = unlines $ + ["instance Compos Tree where", + " compos f t = case t of"] + ++ map (" "++) (concatMap prComposCat skel + ++ if not allRecursive then ["_ -> pure t"] else []) + where + prComposCat c@(cat, fs) + | isListCat c = [gId cat +++ "xs" +++ "->" + +++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"] + | otherwise = concatMap (prComposFun cat) fs + prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String] + prComposFun cat c@(fun,args) + | any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs] + | otherwise = [] + where vars = ["x" ++ show n | n <- [1..length args]] + rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args) + where prRec var typ + | not (isTreeType typ) = "<*>" +++ "pure" +++ var + | otherwise = "<*>" +++ "f" +++ var + allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs] + isTreeType cat = cat `elem` (map fst skel ++ builtin) + isList cat = case filter ((==cat) . fst) skel of + [] -> error $ "Unknown cat " ++ show cat + x:_ -> isListCat x + builtin = ["GString", "GInt", "GFloat"] + +showInstanceGADT :: (String,HSkeleton) -> String +showInstanceGADT (_,skel) = unlines $ + ["instance Show (Tree c) where", + " showsPrec n t = case t of"] + ++ map (" "++) (concatMap prShowCat skel) + ++ [" where opar n = if n > 0 then showChar '(' else id", + " cpar n = if n > 0 then showChar ')' else id"] + where + prShowCat c@(cat, fs) + | isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"] + | otherwise = map (prShowFun cat) fs + prShowFun :: OIdent -> (OIdent,[OIdent]) -> String + prShowFun cat (fun,args) + | null vars = gId fun +++ "->" +++ "showString" +++ show fun + | otherwise = gId fun +++ unwords vars +++ "->" + +++ "opar n . showString" +++ show fun + +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars] + +++ ". cpar n" + where vars = ["x" ++ show n | n <- [1..length args]] + +hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton) +hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where + collectR rr hh = + case rr of + (fun,typ):rs -> case catSkeleton typ of + Ok (cats,cat) -> + collectR rs (updateSkeleton (symid (snd cat)) hh (fun, + map (symid . snd) cats)) + _ -> collectR rs hh + _ -> hh + cats = [symid cat | (cat,GFC.AbsCat _ _) <- defs] + rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs] + + defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m] + name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m] + +updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton +updateSkeleton cat skel rule = + case skel of + (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr + (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule + _ -> error $ cat ++ ": updating empty skeleton with" +++ show rule + +isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool +isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where c = elemCat cat + fs = map fst rules + +-- | Gets the element category of a list category. +elemCat :: OIdent -> OIdent +elemCat = drop 4 + +isBaseFun :: OIdent -> Bool +isBaseFun f = "Base" `isPrefixOf` f + +isConsFun :: OIdent -> Bool +isConsFun f = "Cons" `isPrefixOf` f + +baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int +baseSize (_,rules) = length bs + where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src-3.0/GF/API/GrammarToTransfer.hs b/src-3.0/GF/API/GrammarToTransfer.hs new file mode 100644 index 000000000..658c15184 --- /dev/null +++ b/src-3.0/GF/API/GrammarToTransfer.hs @@ -0,0 +1,94 @@ +---------------------------------------------------------------------- +-- | +-- Module : GrammarToTransfer +-- Maintainer : Björn Bringert +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 12:39:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- Creates a data type definition in the transfer language +-- for an abstract module. +----------------------------------------------------------------------------- + +module GF.API.GrammarToTransfer (grammar2transfer) where + +import qualified GF.Canon.GFC as GFC +import qualified GF.Grammar.Abstract as A +import GF.Grammar.Macros + +import GF.Infra.Modules +import GF.Data.Operations + +import Transfer.Syntax.Abs as S +import Transfer.Syntax.Print + + +-- | the main function +grammar2transfer :: GFC.CanonGrammar -> String +grammar2transfer gr = printTree $ S.Module imports decls + where + cat = S.Ident "Cat" -- FIXME + tree = S.Ident "Tree" -- FIXME + defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m] + -- get category name and context + cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs] + -- get function name and type + funs = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs] + name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m] + imports = [Import (S.Ident "prelude")] + decls = [cats2cat cat tree cats, funs2tree cat tree funs] ++ instances tree + + +-- | Create a declaration of the type of categories given a list +-- of category names and their contexts. +cats2cat :: S.Ident -- ^ the name of the Cat type + -> S.Ident -- ^ the name of the Tree type + -> [(A.Ident,A.Context)] -> Decl +cats2cat cat tree = S.DataDecl cat S.EType . map (uncurry catCons) + where + catCons i c = S.ConsDecl (id2id i) (catConsType c) + catConsType = foldr pi (S.EVar cat) + pi (i,x) t = mkPi (id2pv i) (addTree tree $ term2exp x) t + +funs2tree :: S.Ident -- ^ the name of the Cat type + -> S.Ident -- ^ the name of the Tree type + -> [(A.Ident,A.Type)] -> Decl +funs2tree cat tree = + S.DataDecl tree (S.EPiNoVar (S.EVar cat) S.EType) . map (uncurry funCons) + where + funCons i t = S.ConsDecl (id2id i) (addTree tree $ term2exp t) + +term2exp :: A.Term -> S.Exp +term2exp t = case t of + A.Vr i -> S.EVar (id2id i) + A.App t1 t2 -> S.EApp (term2exp t1) (term2exp t2) + A.Abs i t1 -> S.EAbs (id2pv i) (term2exp t1) + A.Prod i t1 t2 -> mkPi (id2pv i) (term2exp t1) (term2exp t2) + A.Q m i -> S.EVar (id2id i) + _ -> error $ "term2exp: can't handle " ++ show t + +mkPi :: S.VarOrWild -> S.Exp -> S.Exp -> S.Exp +mkPi VWild t e = S.EPiNoVar t e +mkPi v t e = S.EPi v t e + +id2id :: A.Ident -> S.Ident +id2id = S.Ident . symid + +id2pv :: A.Ident -> S.VarOrWild +id2pv i = case symid i of + "h_" -> S.VWild -- FIXME: hacky? + x -> S.VVar (S.Ident x) + +-- FIXME: I think this is not general enoguh. +addTree :: S.Ident -> S.Exp -> S.Exp +addTree tree x = case x of + S.EPi i t e -> S.EPi i (addTree tree t) (addTree tree e) + S.EPiNoVar t e -> S.EPiNoVar (addTree tree t) (addTree tree e) + e -> S.EApp (S.EVar tree) e + +instances :: S.Ident -> [S.Decl] +instances tree = [DeriveDecl (S.Ident "Eq") tree, + DeriveDecl (S.Ident "Compos") tree] diff --git a/src-3.0/GF/API/IOGrammar.hs b/src-3.0/GF/API/IOGrammar.hs new file mode 100644 index 000000000..bd7fc5648 --- /dev/null +++ b/src-3.0/GF/API/IOGrammar.hs @@ -0,0 +1,96 @@ +---------------------------------------------------------------------- +-- | +-- Module : IOGrammar +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:40 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.20 $ +-- +-- for reading grammars and terms from strings and files +----------------------------------------------------------------------------- + +module GF.API.IOGrammar (shellStateFromFiles, + getShellStateFromFiles) where + +import GF.Grammar.Abstract +import qualified GF.Canon.GFC as GFC +import GF.Compile.PGrammar +import GF.Grammar.TypeCheck +import GF.Compile.Compile +import GF.Compile.ShellState +import GF.Compile.NoParse +import GF.Probabilistic.Probabilistic +import GF.UseGrammar.Treebank + +import GF.Infra.Modules +import GF.Infra.ReadFiles (isOldFile) +import GF.Infra.Option +import GF.Data.Operations +import GF.Infra.UseIO +import GF.System.Arch + +import qualified Transfer.InterpreterAPI as T + +import Control.Monad (liftM) +import System.FilePath + +-- | a heuristic way of renaming constants is used +string2absTerm :: String -> String -> Term +string2absTerm m = renameTermIn m . pTrm + +renameTermIn :: String -> Term -> Term +renameTermIn m = refreshMetas [] . rename [] where + rename vs t = case t of + Abs x b -> Abs x (rename (x:vs) b) + Vr c -> if elem c vs then t else Q (zIdent m) c + App f a -> App (rename vs f) (rename vs a) + _ -> t + +string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree +string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt + +----string2paramList :: ConcreteST -> String -> [Term] +---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList + +shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState +shellStateFromFiles opts st file = do + ign <- ioeIO $ getNoparseFromFile opts file + let top = identC $ justModuleName file + sh <- case takeExtensions file of + ".trc" -> do + env <- ioeIO $ T.loadFile file + return $ addTransfer (top,env) st + ".gfcm" -> do + cenv <- compileOne opts (compileEnvShSt st []) file + ioeErr $ updateShellState opts ign Nothing st cenv + s | elem s [".cf",".ebnf"] -> do + let osb = addOptions (options []) opts + grts <- compileModule osb st file + ioeErr $ updateShellState opts ign Nothing st grts + s | oElem (iOpt "treebank") opts -> do + tbs <- ioeIO $ readUniTreebanks file + return $ addTreebanks tbs st + _ -> do + b <- ioeIO $ isOldFile file + let opts' = if b then (addOption showOld opts) else opts + + let osb = if oElem showOld opts' + then addOptions (options []) opts' -- for old no emit + else addOptions (options [emitCode]) opts' + grts <- compileModule osb st file + let mtop = if oElem showOld opts' then Nothing else Just top + ioeErr $ updateShellState opts' ign mtop st grts + if (isSetFlag opts probFile || oElem (iOpt "prob") opts) + then do + probs <- ioeIO $ getProbsFromFile opts file + let lang = maybe top id $ concrete sh --- to work with cf, too + ioeErr $ addProbs (lang,probs) sh + else return sh + +getShellStateFromFiles :: Options -> FilePath -> IO ShellState +getShellStateFromFiles os = + useIOE emptyShellState . + shellStateFromFiles os emptyShellState diff --git a/src-3.0/GF/API/MyParser.hs b/src-3.0/GF/API/MyParser.hs new file mode 100644 index 000000000..c926fe865 --- /dev/null +++ b/src-3.0/GF/API/MyParser.hs @@ -0,0 +1,25 @@ +---------------------------------------------------------------------- +-- | +-- Module : MyParser +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- template to define your own parser (obsolete?) +----------------------------------------------------------------------------- + +module GF.API.MyParser (myParser) where + +import GF.Compile.ShellState +import GF.CF.CFIdent +import GF.CF.CF +import GF.Data.Operations + +-- type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String) + +myParser :: StateGrammar -> CFCat -> CFParser +myParser gr cat toks = ([],"Would you like to add your own parser?") diff --git a/src-3.0/GF/CF/CF.hs b/src-3.0/GF/CF/CF.hs new file mode 100644 index 000000000..9233e905a --- /dev/null +++ b/src-3.0/GF/CF/CF.hs @@ -0,0 +1,213 @@ +---------------------------------------------------------------------- +-- | +-- Module : CF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- context-free grammars. AR 15\/12\/1999 -- 30\/3\/2000 -- 2\/6\/2001 -- 3\/12\/2001 +----------------------------------------------------------------------------- + +module GF.CF.CF (-- * Types + CF(..), CFRule, CFRuleGroup, + CFItem(..), CFTree(..), CFPredef, CFParser, + RegExp(..), CFWord, + -- * Functions + cfParseResults, + -- ** to construct CF grammars + emptyCF, emptyCFPredef, rules2CF, groupCFRules, + -- ** to construct rules + atomCFRule, atomCFTerm, atomRegExp, altsCFTerm, + -- ** to construct trees + atomCFTree, buildCFTree, + -- ** to decide whether a token matches a terminal item + matchCFTerm, satRegExp, + -- ** to analyse a CF grammar + catsOfCF, rulesOfCF, ruleGroupsOfCF, rulesForCFCat, + valCatCF, valItemsCF, valFunCF, + startCat, predefOfCF, appCFPredef, valCFItem, + cfTokens, wordsOfRegExp, forCFItem, + isCircularCF, predefRules + ) where + +import GF.Data.Operations +import GF.Data.Str +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.CF.CFIdent +import Data.List (nub,nubBy) +import Data.Char (isUpper, isLower, toUpper, toLower) + +-- CF grammar data types + +-- | abstract type CF. +-- Invariant: each category has all its rules grouped with it +-- also: the list is never empty (the category is just missing then) +newtype CF = CF ([CFRuleGroup], CFPredef) +type CFRule = (CFFun, (CFCat, [CFItem])) +type CFRuleGroup = (CFCat,[CFRule]) + +-- | CFPredef is a hack for variable symbols and literals; normally = @const []@ +data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show) + +newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show) + +-- | recognize literals, variables, etc +type CFPredef = CFTok -> [(CFCat, CFFun)] + +-- | Wadler style + return information +type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String) + +cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree] +cfParseResults rs = [b | (b,[]) <- fst rs] + +-- | terminals are regular expressions on words; to be completed to full regexp +data RegExp = + RegAlts [CFWord] -- ^ list of alternative words + | RegSpec CFTok -- ^ special token + deriving (Eq, Ord, Show) + +type CFWord = String + +-- the above types should be kept abstract, and the following functions used + +-- to construct CF grammars + +emptyCF :: CF +emptyCF = CF ([], emptyCFPredef) + +emptyCFPredef :: CFPredef +emptyCFPredef = const [] + +rules2CF :: [CFRule] -> CF +rules2CF rs = CF (groupCFRules rs, emptyCFPredef) + +groupCFRules :: [CFRule] -> [(CFCat,[CFRule])] +groupCFRules = foldr ins [] where + ins rule crs = case crs of + (c,r) : rs | compatCF c cat -> (c,rule:r) : rs + cr : rs -> cr : ins rule rs + _ -> [(cat,[rule])] + where + cat = valCatCF rule + +-- to construct rules + +-- | make a rule from a single token without constituents +atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule +atomCFRule c f s = (f, (c, [atomCFTerm s])) + +-- | usual terminal +atomCFTerm :: CFTok -> CFItem +atomCFTerm = CFTerm . atomRegExp + +atomRegExp :: CFTok -> RegExp +atomRegExp t = case t of + TS s -> RegAlts [s] + _ -> RegSpec t + +-- | terminal consisting of alternatives +altsCFTerm :: [String] -> CFItem +altsCFTerm = CFTerm . RegAlts + + +-- to construct trees + +-- | make a tree without constituents +atomCFTree :: CFCat -> CFFun -> CFTree +atomCFTree c f = buildCFTree c f [] + +-- | make a tree with constituents. +buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree +buildCFTree c f trees = CFTree (f,(c,trees)) + +{- ---- +cfMeta0 :: CFTree +cfMeta0 = atomCFTree uCFCat metaCFFun + +-- used in happy +litCFTree :: String -> CFTree --- Maybe CFTree +litCFTree s = maybe cfMeta0 id $ do + (c,f) <- getCFLiteral s + return $ buildCFTree c f [] +-} + +-- to decide whether a token matches a terminal item + +matchCFTerm :: CFItem -> CFTok -> Bool +matchCFTerm (CFTerm t) s = satRegExp t s +matchCFTerm _ _ = False + +satRegExp :: RegExp -> CFTok -> Bool +satRegExp r t = case (r,t) of + (RegAlts tt, TS s) -> elem s tt + (RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s] + (RegSpec x, _) -> t == x --- + _ -> False + where + caseUpperOrLower s = case s of + c:cs | isUpper c -> [s, toLower c : cs] + c:cs | isLower c -> [s, toUpper c : cs] + _ -> [s] + +-- to analyse a CF grammar + +catsOfCF :: CF -> [CFCat] +catsOfCF (CF (rr,_)) = map fst rr + +rulesOfCF :: CF -> [CFRule] +rulesOfCF (CF (rr,_)) = concatMap snd rr + +ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])] +ruleGroupsOfCF (CF (rr,_)) = rr + +rulesForCFCat :: CF -> CFCat -> [CFRule] +rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr + +valCatCF :: CFRule -> CFCat +valCatCF (_,(c,_)) = c + +valItemsCF :: CFRule -> [CFItem] +valItemsCF (_,(_,i)) = i + +valFunCF :: CFRule -> CFFun +valFunCF (f,(_,_)) = f + +startCat :: CF -> CFCat +startCat (CF (rr,_)) = fst (head rr) --- hardly useful + +predefOfCF :: CF -> CFPredef +predefOfCF (CF (_,f)) = f + +appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)] +appCFPredef = ($) . predefOfCF + +valCFItem :: CFItem -> Either RegExp CFCat +valCFItem (CFTerm r) = Left r +valCFItem (CFNonterm nt) = Right nt + +cfTokens :: CF -> [CFWord] +cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf, + CFTerm i <- valItemsCF r] + +wordsOfRegExp :: RegExp -> [CFWord] +wordsOfRegExp (RegAlts tt) = tt +wordsOfRegExp _ = [] + +forCFItem :: CFTok -> CFRule -> Bool +forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a +forCFItem _ _ = False + +-- | we should make a test of circular chains, too +isCircularCF :: CFRule -> Bool +isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c +isCircularCF _ = False + +-- | coercion to the older predef cf type +predefRules :: CFPredef -> CFTok -> [CFRule] +predefRules pre s = [atomCFRule c f s | (c,f) <- pre s] + diff --git a/src-3.0/GF/CF/CFIdent.hs b/src-3.0/GF/CF/CFIdent.hs new file mode 100644 index 000000000..02ee482c0 --- /dev/null +++ b/src-3.0/GF/CF/CFIdent.hs @@ -0,0 +1,253 @@ +---------------------------------------------------------------------- +-- | +-- Module : CFIdent +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:40 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.13 $ +-- +-- symbols (categories, functions) for context-free grammars. +----------------------------------------------------------------------------- + +module GF.CF.CFIdent (-- * Tokens and categories + CFTok(..), CFCat(..), + tS, tC, tL, tI, tF, tV, tM, tInt, + prCFTok, + -- * Function names and profiles + CFFun(..), Profile, + wordsCFTok, + -- * CF Functions + mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun, + intCFFun, floatCFFun, dummyCFFun, + cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun, + -- * CF Categories + mkCIdent, ident2CFCat, labels2CFCat, string2CFCat, + catVarCF, cat2CFCat, cfCatString, cfCatInt,cfCatFloat, + moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat, + -- * CF Tokens + string2CFTok, str2cftoks, + -- * Comparisons + compatToks, compatTok, compatCFFun, compatCF, + wordsLits + ) where + +import GF.Data.Operations +import GF.Canon.GFC +import GF.Infra.Ident +import GF.Grammar.Values (cPredefAbs) +import GF.Canon.AbsGFC +import GF.Grammar.Macros (ident2label) +import GF.Grammar.PrGrammar +import GF.Data.Str +import Data.Char (toLower, toUpper, isSpace) +import Data.List (intersperse) + +-- | this type should be abstract +data CFTok = + TS String -- ^ normal strings + | TC String -- ^ strings that are ambiguous between upper or lower case + | TL String -- ^ string literals + | TI Integer -- ^ integer literals + | TF Double -- ^ float literals + | TV Ident -- ^ variables + | TM Int String -- ^ metavariables; the integer identifies it + deriving (Eq, Ord, Show) + +-- | this type should be abstract +newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show) + +tS :: String -> CFTok +tC :: String -> CFTok +tL :: String -> CFTok +tI :: String -> CFTok +tF :: String -> CFTok +tV :: String -> CFTok +tM :: String -> CFTok + +tS = TS +tC = TC +tL = TL +tI = TI . read +tF = TF . read +tV = TV . identC +tM = TM 0 + +tInt :: Integer -> CFTok +tInt = TI + +prCFTok :: CFTok -> String +prCFTok t = case t of + TS s -> s + TC s -> s + TL s -> s + TI i -> show i + TF i -> show i + TV x -> prt x + TM i m -> m --- "?" --- m + +-- | to build trees: the Atom contains a GF function, @Cn | Meta | Vr | Literal@ +newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show) +-- - - - - - - - - - - - - - - - - - - - - ^^^ added by peb, 21/5-04 + +type Profile = [([[Int]],[Int])] + +wordsCFTok :: CFTok -> [String] +wordsCFTok t = case t of + TC (c:cs) -> [c':cs | c' <- [toUpper c, toLower c]] + _ -> [prCFTok t] + +-- the following functions should be used instead of constructors + +-- to construct CF functions + +mkCFFun :: Atom -> CFFun +mkCFFun t = CFFun (t,[]) + +varCFFun :: Ident -> CFFun +varCFFun = mkCFFun . AV + +consCFFun :: CIdent -> CFFun +consCFFun = mkCFFun . AC + +-- | standard way of making cf fun +string2CFFun :: String -> String -> CFFun +string2CFFun m c = consCFFun $ mkCIdent m c + +stringCFFun :: String -> CFFun +stringCFFun = mkCFFun . AS + +intCFFun :: Integer -> CFFun +intCFFun = mkCFFun . AI + +floatCFFun :: Double -> CFFun +floatCFFun = mkCFFun . AF + +-- | used in lexer-by-need rules +dummyCFFun :: CFFun +dummyCFFun = varCFFun $ identC "_" + +cfFun2String :: CFFun -> String +cfFun2String (CFFun (f,_)) = prt f + +cfFun2Ident :: CFFun -> Ident +cfFun2Ident (CFFun (f,_)) = identC $ prt_ f --- + +cfFun2Profile :: CFFun -> Profile +cfFun2Profile (CFFun (_,p)) = p + +{- ---- +strPro2cfFun :: String -> Profile -> CFFun +strPro2cfFun str p = (CFFun (AC (Ident str), p)) +-} + +metaCFFun :: CFFun +metaCFFun = mkCFFun $ AM 0 + +-- to construct CF categories + +-- | belongs elsewhere +mkCIdent :: String -> String -> CIdent +mkCIdent m c = CIQ (identC m) (identC c) + +ident2CFCat :: CIdent -> Ident -> CFCat +ident2CFCat mc d = CFCat (mc, L d) + +labels2CFCat :: CIdent -> [Label] -> CFCat +labels2CFCat mc d = CFCat (mc, L (identC (concat (intersperse "." (map prt d))))) ---- + +-- | standard way of making cf cat: label s +string2CFCat :: String -> String -> CFCat +string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s") + +idents2CFCat :: Ident -> Ident -> CFCat +idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s") + +catVarCF :: CFCat +catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ---- + +cat2CFCat :: (Ident,Ident) -> CFCat +cat2CFCat = uncurry idents2CFCat + +-- | literals +cfCatString :: CFCat +cfCatString = string2CFCat (prt cPredefAbs) "String" + +cfCatInt, cfCatFloat :: CFCat +cfCatInt = string2CFCat (prt cPredefAbs) "Int" +cfCatFloat = string2CFCat (prt cPredefAbs) "Float" + + + +{- ---- +uCFCat :: CFCat +uCFCat = cat2CFCat uCat +-} + +moduleOfCFCat :: CFCat -> Ident +moduleOfCFCat (CFCat (CIQ m _, _)) = m + +-- | the opposite direction +cfCat2Cat :: CFCat -> (Ident,Ident) +cfCat2Cat (CFCat (CIQ m c,_)) = (m,c) + +cfCat2Ident :: CFCat -> Ident +cfCat2Ident = snd . cfCat2Cat + +lexCFCat :: CFCat -> CFCat +lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*") + +-- to construct CF tokens + +string2CFTok :: String -> CFTok +string2CFTok = tS + +str2cftoks :: Str -> [CFTok] +str2cftoks = map tS . wordsLits . sstr + +-- decide if two token lists look the same (in parser postprocessing) + +compatToks :: [CFTok] -> [CFTok] -> Bool +compatToks ts us = and [compatTok t u | (t,u) <- zip ts us] + +compatTok :: CFTok -> CFTok -> Bool +compatTok (TM _ _) _ = True --- hack because metas are renamed +compatTok _ (TM _ _) = True +compatTok t u = any (`elem` (alts t)) (alts u) where + alts u = case u of + TC (c:s) -> [toLower c : s, toUpper c : s] + TL s -> [s, prQuotedString s] + _ -> [prCFTok u] + +-- | decide if two CFFuns have the same function head (profiles may differ) +compatCFFun :: CFFun -> CFFun -> Bool +compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g + +-- | decide whether two categories match +-- the modifiers can be from different modules, but on the same extension +-- path, so there is no clash, and they can be safely ignored --- +compatCF :: CFCat -> CFCat -> Bool +----compatCF = (==) +compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l' + +-- | Like 'words', but does not split on whitespace inside +-- double quotes.wordsLits :: String -> [String] +-- Also treats escaped quotes in quotes (AR 21/12/2005) by breaks +-- instead of break +wordsLits [] = [] +wordsLits (c:cs) | isSpace c = wordsLits (dropWhile isSpace cs) + | isQuote c + = let (l,rs) = breaks (==c) cs + rs' = drop 1 rs + in ([c]++l++[c]):wordsLits rs' + | otherwise = let (w,rs) = break isSpaceQ cs + in (c:w):wordsLits rs + where + breaks c cs = case break c cs of + (l@(_:_),d:rs) | last l == '\\' -> + let (r,ts) = breaks c rs in (l++[d]++r, ts) + v -> v + isQuote c = elem c "\"'" + isSpaceQ c = isSpace c ---- || isQuote c diff --git a/src-3.0/GF/CF/CFtoGrammar.hs b/src-3.0/GF/CF/CFtoGrammar.hs new file mode 100644 index 000000000..5e73aec31 --- /dev/null +++ b/src-3.0/GF/CF/CFtoGrammar.hs @@ -0,0 +1,62 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/CF/CanonToCF.hs b/src-3.0/GF/CF/CanonToCF.hs new file mode 100644 index 000000000..80ce2e79d --- /dev/null +++ b/src-3.0/GF/CF/CanonToCF.hs @@ -0,0 +1,214 @@ +---------------------------------------------------------------------- +-- | +-- Module : CanonToCF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:41 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.15 $ +-- +-- AR 27\/1\/2000 -- 3\/12\/2001 -- 8\/6\/2003 +----------------------------------------------------------------------------- + +module GF.CF.CanonToCF (canon2cf) where + +import GF.System.Tracing -- peb 8/6-04 + +import GF.Data.Operations +import GF.Infra.Option +import GF.Infra.Ident +import GF.Canon.AbsGFC +import GF.Grammar.LookAbs (allBindCatsOf) +import GF.Canon.GFC +import GF.Grammar.Values (isPredefCat,cPredefAbs) +import GF.Grammar.PrGrammar +import GF.Canon.CMacros +import qualified GF.Infra.Modules as M +import GF.CF.CF +import GF.CF.CFIdent +import GF.UseGrammar.Morphology +import GF.Data.Trie2 +import Data.List (nub,partition) +import Control.Monad + +-- | The main function: for a given cnc module 'm', build the CF grammar with all the +-- rules coming from modules that 'm' extends. The categories are qualified by +-- the abstract module name 'a' that 'm' is of. +-- The ign argument tells what rules not to generate a parser for. +canon2cf :: Options -> (Ident -> Bool) -> CanonGrammar -> Ident -> Err CF +canon2cf opts ign gr c = tracePrt "#size of CF" (err id (show.length.rulesOfCF)) $ do -- peb 8/6-04 + let ms = M.allExtends gr c + a <- M.abstractOfConcrete gr c + let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms] + let mms = [(a, tree2list (M.jments m)) | m <- cncs] + cnc <- liftM M.jments $ M.lookupModMod gr c + rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts ign cnc)) mms + let bindcats = map snd $ allBindCatsOf gr + let rules = filter (not . isCircularCF) rules0 ---- temporarily here + let grules = groupCFRules rules + let predef = mkCFPredef opts bindcats grules + return $ CF predef + +cnc2cfCond :: Options -> (Ident -> Bool) -> BinTree Ident Info -> + Ident -> [(Ident,Info)] -> Err [CFRule] +cnc2cfCond opts ign cnc m gr = + liftM concat $ + mapM lin2cf [(m,fun,cat,args,lin) | + (fun, CncFun cat args lin _) <- gr, notign fun, is fun] + where + is f = isInBinTree f cnc + notign = not . ign + +type IFun = Ident +type ICat = CIdent + +-- | all CF rules corresponding to a linearization rule +lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule] +lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do + let rhss0 = allLinBranches lin -- :: [([Label], Term)] + rhss1 <- mapM (mkCFItems m) rhss0 -- :: [([Label], [[PreCFItem]])] + mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat + +-- | making sequences of CF items from every branch in a linearization +mkCFItems :: Ident -> ([Label], Term) -> Err ([Label], [[PreCFItem]]) +mkCFItems m (labs,t) = do + items <- term2CFItems m t + return (labs, items) + +-- | making CF rules from sequences of CF items +mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> ([Label], [[PreCFItem]]) -> Err [CFRule] +mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss + where + mkOneRule its = do + let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its] + profile = mkProfile nonterms + cfcat = labels2CFCat (redirectIdent m cat) lab + cffun = CFFun (AC (CIQ m fun), profile) + cfits = map precf2cf its + return (cffun,(cfcat,cfits)) + mkProfile nonterms = map mkOne args + where + mkOne (A c i) = mkOne (AB c 0 i) + mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i]) + where + mkB x = [k | (k,(j, [LV y], False)) <- nonterms, j == i, y == x] + +-- | intermediate data structure of CFItems with information for profiles +data PreCFItem = + PTerm RegExp -- ^ like ordinary Terminal + | PNonterm CIdent Integer [Label] Bool -- ^ cat, position, part\/bind, whether arg + deriving Eq + +precf2cf :: PreCFItem -> CFItem +precf2cf (PTerm r) = CFTerm r +precf2cf (PNonterm cm _ ls True) = CFNonterm (labels2CFCat cm ls) +precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF + + +-- | the main job in translating linearization rules into sequences of cf items +term2CFItems :: Ident -> Term -> Err [[PreCFItem]] +term2CFItems m t = errIn "forming cf items" $ case t of + S c _ -> t2c c + + T _ cc -> do + its <- mapM t2c [t | Cas _ t <- cc] + tryMkCFTerm (concat its) + V _ cc -> do + its <- mapM t2c [t | t <- cc] + tryMkCFTerm (concat its) + + C t1 t2 -> do + its1 <- t2c t1 + its2 <- t2c t2 + return [x ++ y | x <- its1, y <- its2] + + FV ts -> do + its <- mapM t2c ts + tryMkCFTerm (concat its) + + P (S c _) _ -> t2c c --- w-around for bug in Compute? AR 31/1/2006 + + P arg s -> extrR arg s + + K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]] + + E -> return [[]] + + K (KP d vs) -> do + let its = [PTerm (RegAlts [s]) | s <- d] + let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs] + tryMkCFTerm (its : itss) + + _ -> return [] ---- prtBad "no cf for" t ---- + + where + + t2c = term2CFItems m + + -- optimize the number of rules by a factorization + tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]] + tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss = + case mapM mkOne (counterparts ii) of + Ok tt -> return [tt] + _ -> return ii + where + mkOne cfits = case mapM mkOneTerm cfits of + Ok tt -> return $ PTerm (RegAlts (concat (nub tt))) + _ -> mkOneNonTerm cfits + mkOneTerm (PTerm (RegAlts t)) = return t + mkOneTerm _ = Bad "" + mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) = + if all (== n) cc + then return n + else Bad "" + mkOneNonTerm _ = Bad "" + counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]] + tryMkCFTerm itss = return itss + + extrR arg lab = case (arg0,labs) of + (Arg (A cat pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]] + (Arg (AB cat b pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]] + (Arg (A cat pos), _) -> return [[PNonterm (cIQ cat) pos labs True]] + (Arg (AB cat b pos), _) -> return [[PNonterm (cIQ cat) pos labs True]] + ---- ?? + _ -> prtBad "cannot extract record field from" arg + where + (arg0,labs) = headProj arg [lab] + + headProj r ls = case r of + P r0 l0 -> headProj r0 (l0:ls) + S r0 _ -> headProj r0 ls + _ -> (r,ls) + cIQ c = if isPredefCat c then CIQ cPredefAbs c else CIQ m c + +mkCFPredef :: Options -> [Ident] -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef) +mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where + (ruls,preds) = if oElem lexerByNeed opts -- option -cflexer + then predefLexer rules + else (rules,emptyTrie) + preds0 s = + [(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++ + [(cat, varCFFun x) | TV x <- [s], cat <- catVarCF : bindcats] ++ + [(cfCatString, stringCFFun t) | TL t <- [s]] ++ + [(cfCatInt, intCFFun t) | TI t <- [s]] ++ + [(cfCatFloat, floatCFFun t) | TF t <- [s]] + cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its] + bindcats = [c | c <- cats, elem (cfCat2Ident c) binds] + look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens + +--- TODO: integrate with morphology +--- predefLexer :: [CFRuleGroup] -> ([CFRuleGroup],BinTree (CFTok,[(CFCat, CFFun)])) +predefLexer groups = (reverse ruls, tcompile preds) where + (ruls,preds) = foldr mkOne ([],[]) groups + mkOne group@(cat,rules) (rs,ps) = (rule:rs,pre ++ ps) where + (rule,pre) = case partition isLexical rules of + ([],_) -> (group,[]) + (ls,rest) -> ((cat,rest), concatMap mkLexRule ls) + isLexical (f,(c,its)) = case its of + [CFTerm (RegAlts ws)] -> True + _ -> False + mkLexRule r = case r of + (fun,(cat,[CFTerm (RegAlts ws)])) -> [(w, [(cat,fun)]) | w <- ws] + _ -> [] diff --git a/src-3.0/GF/CF/ChartParser.hs b/src-3.0/GF/CF/ChartParser.hs new file mode 100644 index 000000000..740c4d787 --- /dev/null +++ b/src-3.0/GF/CF/ChartParser.hs @@ -0,0 +1,206 @@ +---------------------------------------------------------------------- +-- | +-- Module : ChartParser +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:12 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.10 $ +-- +-- Bottom-up Kilbury chart parser from "Pure Functional Parsing", chapter 5. +-- OBSOLETE -- should use new MCFG parsers instead +----------------------------------------------------------------------------- + +module GF.CF.ChartParser (chartParser) where + +-- import Tracing +-- import PrintParser +-- import PrintSimplifiedTerm + +import GF.Data.Operations +import GF.CF.CF +import GF.CF.CFIdent +import GF.CF.PPrCF (prCFItem) + +import GF.Data.OrdSet +import GF.Data.OrdMap2 + +import Data.List (groupBy) + +type Token = CFTok +type Name = CFFun +type Category = CFItem +type Grammar = ([Production], Terminal) +type Production = (Name, Category, [Category]) +type Terminal = Token -> [(Category, Maybe Name)] +type GParser = Grammar -> Category -> [Token] -> ([ParseTree],String) +data ParseTree = Node Name Category [ParseTree] | Leaf Token + +maxTake :: Int +-- maxTake = 1000 +maxTake = maxBound + +-------------------------------------------------- +-- converting between GF parsing and CFG parsing + +buildParser :: GParser -> CF -> CFCat -> CFParser +buildParser gparser cf = parse + where + parse = \start input -> + let parse2 = parse' (CFNonterm start) input in + (take maxTake [(parse2tree t, []) | t <- fst parse2], snd parse2) + parse' = gparser (cf2grammar cf) + +cf2grammar :: CF -> Grammar +cf2grammar cf = (productions, terminal) + where + productions = [ (name, CFNonterm cat, rhs) | + (name, (cat, rhs)) <- cfRules ] + terminal tok = [ (CFNonterm cat, Just name) | + (cat, name) <- cfPredef tok ] + ++ + [ (item, Nothing) | + item <- elems rhsItems, + matchCFTerm item tok ] + cfRules = rulesOfCF cf + cfPredef = predefOfCF cf + rhsItems :: Set Category + rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ] + +parse2tree :: ParseTree -> CFTree +parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees')) + where + trees' = [ parse2tree t | t@(Node _ _ _) <- trees ] -- ignore leafs + +maybeNode :: Maybe Name -> Category -> Token -> ParseTree +maybeNode (Just name) cat tok = Node name cat [Leaf tok] +maybeNode Nothing _ tok = Leaf tok + + +-------------------------------------------------- +-- chart parsing (bottom up kilbury-like) + +type Chart = [CState] +type CState = Set Edge +type Edge = (Int, Category, [Category]) +type Passive = (Int, Int, Category) + +chartParser :: CF -> CFCat -> CFParser +chartParser = buildParser chartParser0 + +chartParser0 :: GParser +chartParser0 (productions, terminal) = cparse + where + emptyCats :: Set Category + emptyCats = empties emptySet + where + empties cats | cats==cats' = cats + | otherwise = empties cats' + where cats' = makeSet [ cat | (_, cat, rhs) <- productions, + all (`elemSet` cats) rhs ] + + grammarMap :: Map Category [(Name, [Category])] + grammarMap = makeMapWith (++) + [ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ] + + leftCornerMap :: Map Category (Set (Category,[Category])) + leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) | + (_, b, abs) <- productions, + (a : bs) <- removeNullable abs ] + + removeNullable :: [Category] -> [[Category]] + removeNullable [] = [] + removeNullable cats@(cat:cats') + | cat `elemSet` emptyCats = cats : removeNullable cats' + | otherwise = [cats] + + cparse :: Category -> [Token] -> ([ParseTree], String) + cparse start input = -- trace "ChartParser" $ + case lookup (0, length input, start) $ + -- tracePrt "#edgeTrees" (prt . map (length.snd)) $ + edgeTrees of + Just trees -> -- tracePrt "#trees" (prt . length . fst) $ + (trees, "Chart:" ++++ prChart passiveEdges) + Nothing -> ([], "Chart:" ++++ prChart passiveEdges) + where + finalChart :: Chart + finalChart = map buildState initialChart + + finalChartMap :: [Map Category (Set Edge)] + finalChartMap = map stateMap finalChart + + stateMap :: CState -> Map Category (Set Edge) + stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) | + (i, b, a:bs) <- elems state ] + + initialChart :: Chart + initialChart = -- tracePrt "#initialChart" (prt . map (length.elems)) $ + emptySet : map initialState (zip [0..] input) + where initialState (j, sym) = makeSet [ (j, cat, []) | + (cat, _) <- terminal sym ] + + buildState :: CState -> CState + buildState = limit more + where more (j, a, []) = ordSet [ (j, b, bs) | + (b, bs) <- elems (lookupWith emptySet leftCornerMap a) ] + <++> + lookupWith emptySet (finalChartMap !! j) a + more (j, b, a:bs) = ordSet [ (j, b, bs) | + a `elemSet` emptyCats ] + + passiveEdges :: [Passive] + passiveEdges = -- tracePrt "#passiveEdges" (prt . length) $ + [ (i, j, cat) | + (j, state) <- zip [0..] $ + -- tracePrt "#passiveChart" + -- (prt . map (length.filter (\(_,_,x)->null x).elems)) $ + -- tracePrt "#activeChart" (prt . map (length.elems)) $ + finalChart, + (i, cat, []) <- elems state ] + ++ + [ (i, i, cat) | + i <- [0 .. length input], + cat <- elems emptyCats ] + + edgeTrees :: [ (Passive, [ParseTree]) ] + edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ] + + edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])] + edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) | + ((i,j,c), trees) <- edgeTrees ] + + treesFor :: Passive -> [ParseTree] + treesFor (i, j, cat) = [ Node name cat trees | + (name, rhs) <- lookupWith [] grammarMap cat, + trees <- children rhs i j ] + ++ + [ maybeNode name cat tok | + i == j-1, + let tok = input !! i, + Just name <- [lookup cat (terminal tok)] ] + + children :: [Category] -> Int -> Int -> [[ParseTree]] + children [] i k = [ [] | i == k ] + children (c:cs) i k = [ tree : rest | + i <= k, + (j, trees) <- lookupWith [] edgeTreesMap (i,c), + rest <- children cs j k, + tree <- trees ] + + +{- +instance Print ParseTree where + prt (Node name cat trees) = prt name++"."++prt cat++"^{"++prtSep "," trees++"}" + prt (Leaf token) = prt token +-} + +-- AR 10/12/2002 + +prChart :: [Passive] -> String +prChart = unlines . map (unwords . map prOne) . positions where + prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it + positions = groupBy (\ (i,_,_) (j,_,_) -> i == j) + + diff --git a/src-3.0/GF/CF/EBNF.hs b/src-3.0/GF/CF/EBNF.hs new file mode 100644 index 000000000..f091d19cb --- /dev/null +++ b/src-3.0/GF/CF/EBNF.hs @@ -0,0 +1,191 @@ +---------------------------------------------------------------------- +-- | +-- Module : EBNF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:13 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.5 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.CF.EBNF (pEBNFasGrammar) where + +import GF.Data.Operations +import GF.Data.Parsers +import GF.Infra.Comments +import GF.CF.CF +import GF.CF.CFIdent +import GF.Grammar.Grammar +import GF.Grammar.PrGrammar +import GF.CF.CFtoGrammar +import qualified GF.Source.AbsGF as A + +import Data.List (nub, partition) + +-- AR 18/4/2000 - 31/3/2004 + +-- Extended BNF grammar with token type a +-- put a = String for simple applications + +type EBNF = [ERule] +type ERule = (ECat, ERHS) +type ECat = (String,[Int]) +type ETok = String + +ebnfID = "EBNF" ---- make this parametric! + +data ERHS = + ETerm ETok + | ENonTerm ECat + | ESeq ERHS ERHS + | EAlt ERHS ERHS + | EStar ERHS + | EPlus ERHS + | EOpt ERHS + | EEmpty + +type CFRHS = [CFItem] +type CFJustRule = (CFCat, CFRHS) + +ebnf2gf :: EBNF -> [A.TopDef] +ebnf2gf = cf2grammar . rules2CF . ebnf2cf + +ebnf2cf :: EBNF -> [CFRule] +ebnf2cf ebnf = [(mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where + mkCFF i (CFCat (_,c), _) = string2CFFun ebnfID ("Mk" ++ prt c ++ "_" ++ show i) + +normEBNF :: EBNF -> [CFJustRule] +normEBNF erules = let + erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules] + erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad ! + erules3 = concat (map pickERules erules2) + erules4 = nubERules erules3 + in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss] + +refreshECats :: [NormERule] -> [NormERule] +refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where + recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its]) + recss ii n [] = [] + recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss + recit ii it = case it of + EINonTerm cat -> EINonTerm (updECat ii cat) + EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t]) + EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t]) + EIOpt (cat,t) -> EIOpt (updECat ii cat, [recss ii 0 s | s <- t]) + _ -> it + +pickERules :: NormERule -> [NormERule] +pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where + pics it = case it of + EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru + EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru + EIOpt ru@(cat,t) -> mkEOptRules cat ++ pickERules ru + _ -> [] + mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])] + where cat' = mkNewECat cat "Star" + mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])] + where cat' = mkNewECat cat "Plus" + mkEOptRules cat = [(cat', [[],[EINonTerm cat]])] + where cat' = mkNewECat cat "Opt" + +nubERules :: [NormERule] -> [NormERule] +nubERules rules = nub optim where + optim = map (substERules (map mkSubst replaces)) irreducibles + (replaces,irreducibles) = partition reducible rules + reducible (cat,[items]) = isNewCat cat && all isOldIt items + reducible _ = False + isNewCat (_,ints) = ints == [] + isOldIt (EITerm _) = True + isOldIt (EINonTerm cat) = not (isNewCat cat) + isOldIt _ = False + mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton +--- the optimization assumes each cat has at most one EBNF rule. + +substERules :: [(ECat,[EItem])] -> NormERule -> NormERule +substERules g (cat,itss) = (cat, map sub itss) where + sub [] = [] + sub (i@(EINonTerm cat') : ii) = case lookup cat g of + Just its -> its ++ sub ii + _ -> i : sub ii + sub (EIStar r : ii) = EIStar (substERules g r) : ii + sub (EIPlus r : ii) = EIPlus (substERules g r) : ii + sub (EIOpt r : ii) = EIOpt (substERules g r) : ii + +eitem2cfitem :: EItem -> CFItem +eitem2cfitem it = case it of + EITerm a -> atomCFTerm $ tS a + EINonTerm cat -> CFNonterm (mkCFCatE cat) + EIStar (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Star")) + EIPlus (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Plus")) + EIOpt (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Opt")) + +type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items + +data EItem = + EITerm String + | EINonTerm ECat + | EIStar NormERule + | EIPlus NormERule + | EIOpt NormERule + deriving Eq + +normERule :: ([Int],ERule) -> NormERule +normERule (ii,(cat,rhs)) = + (cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where + disjNorm r = case r of + ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2] + EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2 + EEmpty -> [[]] + _ -> [[r]] + +mkEItem :: [Int] -> ERHS -> EItem +mkEItem ii rhs = case rhs of + ETerm a -> EITerm a + ENonTerm cat -> EINonTerm cat + EStar r -> EIStar (normERule (ii,(mkECat ii, r))) + EPlus r -> EIPlus (normERule (ii,(mkECat ii, r))) + EOpt r -> EIOpt (normERule (ii,(mkECat ii, r))) + _ -> EINonTerm ("?????",[]) +-- _ -> error "should not happen in ebnf" --- + +mkECat ints = ("C", ints) + +prECat (c,[]) = c +prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints) + +mkCFCatE :: ECat -> CFCat +mkCFCatE = string2CFCat ebnfID . prECat + +updECat _ (c,[]) = (c,[]) +updECat ii (c,_) = (c,ii) + +mkNewECat (c,ii) str = (c ++ str,ii) + +------ parser for EBNF grammars + +pEBNFasGrammar :: String -> Err [A.TopDef] +pEBNFasGrammar = parseResultErr (pEBNF *** ebnf2gf) . remComments + +pEBNF :: Parser Char EBNF +pEBNF = longestOfMany (pJ pERule) + +pERule :: Parser Char ERule +pERule = pECat ... pJ (literals ":=" ||| literals "::=") +.. pERHS 0 ..+ jL ";" + +pERHS :: Int -> Parser Char ERHS +pERHS 0 = pTList "|" (pERHS 1) *** foldr1 EAlt +pERHS 1 = longestOfMany (pJ (pERHS 2)) *** foldr ESeq EEmpty +pERHS 2 = pERHS 3 ... pJ pUnaryEOp *** (\ (a,f) -> f a) +pERHS 3 = pQuotedString *** ETerm + ||| pECat *** ENonTerm ||| pParenth (pERHS 0) + +pUnaryEOp :: Parser Char (ERHS -> ERHS) +pUnaryEOp = + lits "*" <<< EStar ||| lits "+" <<< EPlus ||| lits "?" <<< EOpt ||| succeed id + +pECat = pIdent *** (\c -> (c,[])) + diff --git a/src-3.0/GF/CF/PPrCF.hs b/src-3.0/GF/CF/PPrCF.hs new file mode 100644 index 000000000..1c2203e94 --- /dev/null +++ b/src-3.0/GF/CF/PPrCF.hs @@ -0,0 +1,102 @@ +---------------------------------------------------------------------- +-- | +-- Module : PPrCF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/15 17:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.13 $ +-- +-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003 +-- +-- use the Print class instead! +----------------------------------------------------------------------------- + +module GF.CF.PPrCF (prCF, prCFTree, prCFRule, prCFFun, prCFCat, prCFItem, prRegExp, pCF) where + +import GF.Data.Operations +import GF.CF.CF +import GF.CF.CFIdent +import GF.Canon.AbsGFC +import GF.Grammar.PrGrammar + +import Data.Char +import Data.List + +prCF :: CF -> String +prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function + +prCFTree :: CFTree -> String +prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where + prs [] = "" + prs ts = " " ++ unwords (map ps ts) + ps t@(CFTree (_,(_,[]))) = prCFTree t + ps t = prParenth (prCFTree t) +{-# NOINLINE prCFTree #-} +-- Workaround ghc 6.8.2 bug + + +prCFRule :: CFRule -> String +prCFRule (fun,(cat,its)) = + prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++ + unwords (map prCFItem its) +++ ";" + +prCFFun :: CFFun -> String +prCFFun = prCFFun' True ---- False -- print profiles for debug + +prCFFun' :: Bool -> CFFun -> String +prCFFun' profs (CFFun (t, p)) = prt_ t ++ pp p where + pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p) + normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])] + +prCFCat :: CFCat -> String +prCFCat (CFCat (c,l)) = prt_ c ++ case prt_ l of + "s" -> [] + _ -> "-" ++ prt_ l ---- + +prCFItem :: CFItem -> String +prCFItem (CFNonterm c) = prCFCat c +prCFItem (CFTerm a) = prRegExp a + +prRegExp :: RegExp -> String +prRegExp (RegAlts tt) = case tt of + [t] -> prQuotedString t + _ -> prParenth (prTList " | " (map prQuotedString tt)) + +-- rules have an amazingly easy parser, if we use the format +-- fun. C -> item1 item2 ... where unquoted items are treated as cats +-- Actually would be nice to add profiles to this. + +getCFRule :: String -> String -> Err [CFRule] +getCFRule mo s = getcf (wrds s) where + getcf ws = case ws of + fun : cat : a : its | isArrow a -> + Ok [(string2CFFun mo (init fun), + (string2CFCat mo cat, map mkIt its))] + cat : a : its | isArrow a -> + Ok [(string2CFFun mo (mkFun cat it), + (string2CFCat mo cat, map mkIt it)) | it <- chunk its] + _ -> Bad (" invalid rule:" +++ s) + isArrow a = elem a ["->", "::="] + mkIt w = case w of + ('"':w@(_:_)) -> atomCFTerm (string2CFTok (init w)) + _ -> CFNonterm (string2CFCat mo w) + chunk its = case its of + [] -> [[]] + _ -> chunks "|" its + mkFun cat its = case its of + [] -> cat ++ "_" + _ -> concat $ intersperse "_" (cat : map clean its) -- CLE style + clean = filter isAlphaNum -- to form valid identifiers + wrds = takeWhile (/= ";") . words -- to permit semicolon in the end + +pCF :: String -> String -> Err [CFRule] +pCF mo s = do + rules <- mapM (getCFRule mo) $ filter isRule $ lines s + return $ concat rules + where + isRule line = case dropWhile isSpace line of + '-':'-':_ -> False + _ -> not $ all isSpace line diff --git a/src-3.0/GF/CF/PrLBNF.hs b/src-3.0/GF/CF/PrLBNF.hs new file mode 100644 index 000000000..4ba2019bc --- /dev/null +++ b/src-3.0/GF/CF/PrLBNF.hs @@ -0,0 +1,150 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrLBNF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:16 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.11 $ +-- +-- Printing CF grammars generated from GF as LBNF grammar for BNFC. +-- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 -- 27/9/2004. +-- With primitive error messaging, by rules and rule tails commented out +----------------------------------------------------------------------------- + +module GF.CF.PrLBNF (prLBNF,prBNF) where + +import GF.CF.CF +import GF.CF.CFIdent +import GF.Canon.AbsGFC +import GF.Infra.Ident +import GF.Grammar.PrGrammar +import GF.Compile.ShellState +import GF.Canon.GFC +import GF.Canon.Look + +import GF.Data.Operations +import GF.Infra.Modules + +import Data.Char +import Data.List (nub) + +prLBNF :: Bool -> StateGrammar -> String +prLBNF new gr = unlines $ pragmas ++ (map (prCFRule cs) rules') + where + cs = map IC ["Int","String"] ++ [catIdPlus c | (_,(c,_)) <- rules] + cf = stateCF gr + (pragmas,rules) = if new -- tries to treat precedence levels + then mkLBNF (stateGrammarST gr) $ rulesOfCF cf + else ([],rulesOfCF cf) -- "normal" behaviour + rules' = concatMap expand rules + expand (f,(c,its)) = [(f,(c,it)) | it <- combinations (map expIt its)] + expIt i = case i of + CFTerm (RegAlts ss) -> [CFTerm (RegAlts [s]) | s <- ss] + _ -> [i] + +-- | a hack to hide the LBNF details +prBNF :: Bool -> StateGrammar -> String +prBNF b = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF b + where + unLBNF r = case r of + "---":ts -> ts + ";":"---":ts -> ts + c:ts -> c : unLBNF ts + _ -> r + +--- | awful low level code without abstraction over label names etc +mkLBNF :: CanonGrammar -> [CFRule] -> ([String],[CFRule]) +mkLBNF gr rules = (coercions, nub $ concatMap mkRule rules) where + coercions = ["coercions" +++ prt_ c +++ show n +++ ";" | + (_,ModMod m) <- modules gr, + (c,CncCat (RecType ls) _ _) <- tree2list $ jments m, + Lbg (L (IC "p")) (TInts n) <- ls + ] + precedences = [(f,(prec,assoc)) | + (_,ModMod m) <- modules gr, + (f,CncFun _ _ (R lin) _) <- tree2list $ jments m, + (Just prec, Just assoc) <- [( + lookup "p" [(lab,p) | Ass (L (IC lab)) (EInt p) <- lin], + lookup "a" [(lab,a) | Ass (L (IC lab)) (Par (CIQ _ (IC a)) []) <- lin] + )] + ] + precfuns = map fst precedences + mkRule r@(fun@(CFFun (t, p)),(cat,its)) = case t of + AC (CIQ _ c) -> case lookup c precedences of + Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))] + _ -> return r + AD (CIQ _ c) -> case lookup c precedences of + Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))] + _ -> return r + _ -> return r + mkIts cat prec assoc i its = case its of + CFTerm (RegAlts ["("]):n@(CFNonterm k):CFTerm (RegAlts [")"]):rest | k==cat -> + mkIts cat prec assoc i $ n:rest -- remove variants with parentheses + CFNonterm k:rest | k==cat -> + CFNonterm (mkNonterm prec assoc i k) : mkIts cat prec assoc (i+1) rest + it:rest -> it:mkIts cat prec assoc i rest + [] -> [] + + mkCat prec (CFCat ((CIQ m (IC c)),l)) = CFCat ((CIQ m (IC (c ++ show prec ++ "+"))),l) + mkNonterm prec assoc i cat = mkCat prec' cat + where + prec' = case (assoc,i) of + ("PL",0) -> prec + ("PR",0) -> prec + 1 + ("PR",_) -> prec + _ -> prec + 1 + +catId ((CFCat ((CIQ _ c),l))) = c + +catIdPlus ((CFCat ((CIQ _ c@(IC s)),l))) = case reverse s of + '+':cs -> IC $ reverse $ dropWhile isDigit cs + _ -> c + +prCFRule :: [Ident] -> CFRule -> String +prCFRule cs (fun,(cat,its)) = + prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax + unwords (map (prCFItem cs) its) +++ ";" + +prCFFun :: CFCat -> CFFun -> String +prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of + AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) + AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) + _ -> prErr True $ prt t + where + lab = prLab l + f2 f = if null lab then "" else f + prP = concatMap show + +prId b i = case i of + IC "Int" -> "Integer" + IC "#Var" -> "Ident" + IC "Var" -> "Ident" + IC "id_" -> "_" + IC s@(c:_) | last s == '+' -> init s -- hack to save precedence information + IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else "" + _ -> prErr b $ prt i + +prLab i = case i of + L (IC "s") -> "" --- + L (IC "_") -> "" --- + _ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else "" + +-- | just comment out the rest if you cannot interpret the function name in LBNF +-- two versions, depending on whether in the beginning of a rule or elsewhere; +-- in the latter case, error just terminates the rule +prErr :: Bool -> String -> String +prErr b s = (if b then "" else " ;") +++ "---" +++ s + +prCFCat :: Bool -> CFCat -> String +prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ---- + +-- | if a category does not have a production of its own, we replace it by Ident +prCFItem cs (CFNonterm c) = if elem (catIdPlus c) cs then prCFCat False c else "Ident" +prCFItem _ (CFTerm a) = prRegExp a + +prRegExp (RegAlts tt) = case tt of + [t] -> prQuotedString t + _ -> prErr False $ prParenth (prTList " | " (map prQuotedString tt)) diff --git a/src-3.0/GF/CF/Profile.hs b/src-3.0/GF/CF/Profile.hs new file mode 100644 index 000000000..e573bec78 --- /dev/null +++ b/src-3.0/GF/CF/Profile.hs @@ -0,0 +1,106 @@ +---------------------------------------------------------------------- +-- | +-- Module : Profile +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:14 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001 +-- revised 8/4/2002 for the new profile structure +----------------------------------------------------------------------------- + +module GF.CF.Profile (postParse) where + +import GF.Canon.AbsGFC +import GF.Canon.GFC +import qualified GF.Infra.Ident as I +import GF.Canon.CMacros +---import MMacros +import GF.CF.CF +import GF.CF.CFIdent +import GF.CF.PPrCF -- for error msg +import GF.Grammar.PrGrammar + +import GF.Data.Operations + +import Control.Monad +import Data.List (nub) + +-- | the job is done in two passes: +-- +-- 1. tree2term: restore constituent order from Profile +-- +-- 2. term2trm: restore Bindings from Binds +postParse :: CFTree -> Err Exp +postParse tree = do + iterm <- errIn ("postprocessing parse tree" +++ prCFTree tree) $ tree2term tree + return $ term2trm iterm + +-- | an intermediate data structure +data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta deriving (Eq,Show) +type BindVs = [[I.Ident]] + +-- | (1) restore constituent order from Profile +tree2term :: CFTree -> Err ITerm +-- tree2term (CFTree (f,(_,[t]))) | f == dummyCFFun = tree2term t -- not used +tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of + AM _ -> return IMeta + _ -> do + args <- mapM mkArg pro + binds <- mapM mkBinds pro + return $ ITerm (fun, binds) args + where + mkArg (_,arg) = case arg of + [x] -> do -- one occurrence + trx <- trees !? x + tree2term trx + [] -> return IMeta -- suppression + _ -> do -- reduplication + trees' <- mapM (trees !?) arg + xs1 <- mapM tree2term trees' + xs2 <- checkArity xs1 + unif xs2 + + checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 + then Bad "arity error" + else return xs' + where xs' = [t | t@(ITerm _ _) <- xs] + unif xs = case [t | t@(ITerm _ _) <- xs] of + [] -> return $ IMeta + (ITerm fp@(f,_) xx : ts) -> do + let hs = [h | ITerm (h,_) _ <- ts, h /= f] + testErr (null hs) -- if fails, hs must be nonempty + ("unification expects" +++ prt f +++ "but found" +++ prt (head hs)) + xx' <- mapM unifArg [0 .. length xx - 1] + return $ ITerm fp xx' + where + unifArg i = unif [zz !! i | ITerm _ zz <- xs] + + mkBinds (xss,_) = mapM mkBind xss + mkBind xs = do + ts <- mapM (trees !?) xs + let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts] + testErr (length ts == length vs) "non-variable in bound position" + case vs of + [x] -> return x + [] -> return $ I.identC "h_" ---- uBoundVar + y:ys -> do + testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y) + return y + +-- | (2) restore Bindings from Binds +term2trm :: ITerm -> Exp +term2trm IMeta = EAtom (AM 0) ---- mExp0 +term2trm (ITerm (fun, binds) terms) = + let bterms = zip binds terms + in mkAppAtom fun [mkAbsR xs (term2trm t) | (xs,t) <- bterms] + + --- these are deprecated + where + mkAbsR c e = foldr EAbs e c + mkAppAtom a = mkApp (EAtom a) + mkApp = foldl EApp diff --git a/src-3.0/GF/CFGM/AbsCFG.hs b/src-3.0/GF/CFGM/AbsCFG.hs new file mode 100644 index 000000000..063b96802 --- /dev/null +++ b/src-3.0/GF/CFGM/AbsCFG.hs @@ -0,0 +1,45 @@ +module GF.CFGM.AbsCFG where + +-- Haskell module generated by the BNF converter + +newtype Ident = Ident String deriving (Eq,Ord,Show) +newtype SingleQuoteString = SingleQuoteString String deriving (Eq,Ord,Show) +data Grammars = + Grammars [Grammar] + deriving (Eq,Ord,Show) + +data Grammar = + Grammar Ident [Flag] [Rule] + deriving (Eq,Ord,Show) + +data Flag = + StartCat Category + deriving (Eq,Ord,Show) + +data Rule = + Rule Fun Profiles Category [Symbol] + deriving (Eq,Ord,Show) + +data Fun = + Cons Ident + | Coerce + deriving (Eq,Ord,Show) + +data Profiles = + Profiles [Profile] + deriving (Eq,Ord,Show) + +data Profile = + UnifyProfile [Integer] + | ConstProfile Ident + deriving (Eq,Ord,Show) + +data Symbol = + CatS Category + | TermS String + deriving (Eq,Ord,Show) + +data Category = + Category SingleQuoteString + deriving (Eq,Ord,Show) + diff --git a/src-3.0/GF/CFGM/CFG.cf b/src-3.0/GF/CFGM/CFG.cf new file mode 100644 index 000000000..fa722f4a4 --- /dev/null +++ b/src-3.0/GF/CFGM/CFG.cf @@ -0,0 +1,36 @@ +entrypoints Grammars; + +Grammars. Grammars ::= [Grammar]; + +Grammar. Grammar ::= "grammar" Ident [Flag] [Rule] "end" "grammar"; +separator Grammar ""; + +StartCat. Flag ::= "startcat" Category; +terminator Flag ";"; + +Rule. Rule ::= Fun ":" Profiles "." Category "->" [Symbol]; +terminator Rule ";"; + +Cons. Fun ::= Ident ; +Coerce. Fun ::= "_" ; + +Profiles. Profiles ::= "[" [Profile] "]"; + +separator Profile ","; + +UnifyProfile. Profile ::= "[" [Integer] "]"; +ConstProfile. Profile ::= Ident ; + +separator Integer ","; + +CatS. Symbol ::= Category; +TermS. Symbol ::= String; + +-- separator Symbol ""; +[]. [Symbol] ::= "." ; +(:[]). [Symbol] ::= Symbol ; +(:). [Symbol] ::= Symbol [Symbol] ; + +Category. Category ::= SingleQuoteString ; + +token SingleQuoteString '\'' ((char - ["'\\"]) | ('\\' ["'\\"]))* '\'' ; diff --git a/src-3.0/GF/CFGM/LexCFG.hs b/src-3.0/GF/CFGM/LexCFG.hs new file mode 100644 index 000000000..e58fdff5a --- /dev/null +++ b/src-3.0/GF/CFGM/LexCFG.hs @@ -0,0 +1,312 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 3 "LexCFG.x" #-} +module GF.CFGM.LexCFG where + +import GF.Data.ErrM + + +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\xf8\xff\xfd\xff\x02\x00\x00\x00\xd2\xff\x00\x00\xfa\xff\xfc\xff\x2d\x00\xc8\x00\x98\x01\x00\x00\x73\x00\x43\x01\x01\x01\x43\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x02\x00\x00\x00\x06\x00\x00\x00\x05\x00\x02\x00\x05\x00\x03\x00\x04\x00\x03\x00\x00\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x03\x00\x07\x00\x03\x00\x08\x00\x03\x00\x08\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0e\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0e\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\x20\x00\xff\xff\x27\x00\xff\xff\x27\x00\x20\x00\x27\x00\x2c\x00\x2d\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x27\x00\x5d\x00\x5c\x00\x5f\x00\x5c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,15) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[],[(AlexAcc (alex_action_2))],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[],[(AlexAcc (alex_action_5))]] +{-# LINE 33 "LexCFG.x" #-} + +tok f p s = f p s + +share :: String -> String +share = id + +data Tok = + TS !String -- reserved words + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + | T_SingleQuoteString !String + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + PT _ (T_SingleQuoteString s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "grammar" (b "end" N N) (b "startcat" N N) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c + +alex_action_1 = tok (\p s -> PT p (TS $ share s)) +alex_action_2 = tok (\p s -> PT p (eitherResIdent (T_SingleQuoteString . share) s)) +alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_4 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) +alex_action_5 = tok (\p s -> PT p (TI $ share s)) +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + +{-# LINE 35 "GenericTemplate.hs" #-} + + + + + + + + + + + +data AlexAddr = AlexA# Addr# + +{-# INLINE alexIndexShortOffAddr #-} +alexIndexShortOffAddr (AlexA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + case s of + -1# -> (last_acc, input) + _ -> alex_scan_tkn' user orig_input len input s last_acc + +alex_scan_tkn' user orig_input len input s last_acc = + let + new_acc = check_accs (alex_accept `unsafeAt` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexShortOffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexShortOffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexShortOffAddr alex_table offset + else alexIndexShortOffAddr alex_deflt s + in + alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/src-3.0/GF/CFGM/LexCFG.x b/src-3.0/GF/CFGM/LexCFG.x new file mode 100644 index 000000000..f3ecb14eb --- /dev/null +++ b/src-3.0/GF/CFGM/LexCFG.x @@ -0,0 +1,135 @@ +-- -*- haskell -*- +-- This Alex file was machine-generated by the BNF converter +{ +module LexCFG where + +import ErrM + +} + + +$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME +$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME +$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME +$d = [0-9] -- digit +$i = [$l $d _ '] -- identifier character +$u = [\0-\255] -- universal: any character + +@rsyms = -- reserved words consisting of special symbols + \; | \: | \. | \- \> | \_ | \[ | \] | \, + +:- + +$white+ ; +@rsyms { tok (\p s -> PT p (TS $ share s)) } +\' ($u # [\' \\]| \\ [\' \\]) * \' { tok (\p s -> PT p (eitherResIdent (T_SingleQuoteString . share) s)) } + +$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } +\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) } + +$d+ { tok (\p s -> PT p (TI $ share s)) } + + +{ + +tok f p s = f p s + +share :: String -> String +share = id + +data Tok = + TS !String -- reserved words + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + | T_SingleQuoteString !String + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + PT _ (T_SingleQuoteString s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "grammar" (b "end" N N) (b "startcat" N N) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c +} diff --git a/src-3.0/GF/CFGM/ParCFG.hs b/src-3.0/GF/CFGM/ParCFG.hs new file mode 100644 index 000000000..cb70ef30d --- /dev/null +++ b/src-3.0/GF/CFGM/ParCFG.hs @@ -0,0 +1,779 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +module GF.CFGM.ParCFG where +import GF.CFGM.AbsCFG +import GF.CFGM.LexCFG +import GF.Data.ErrM +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.15 + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn4 :: (Ident) -> (HappyAbsSyn ) +happyIn4 x = unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> (Ident) +happyOut4 x = unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (Integer) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Integer) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (String) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (String) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (SingleQuoteString) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (SingleQuoteString) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Grammars) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (Grammars) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Grammar) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Grammar) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: ([Grammar]) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> ([Grammar]) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Flag) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Flag) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: ([Flag]) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> ([Flag]) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (Rule) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (Rule) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: ([Rule]) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> ([Rule]) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Fun) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Fun) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (Profiles) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (Profiles) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([Profile]) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([Profile]) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Profile) -> (HappyAbsSyn ) +happyIn18 x = unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (Profile) +happyOut18 x = unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: ([Integer]) -> (HappyAbsSyn ) +happyIn19 x = unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> ([Integer]) +happyOut19 x = unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (Symbol) -> (HappyAbsSyn ) +happyIn20 x = unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (Symbol) +happyOut20 x = unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: ([Symbol]) -> (HappyAbsSyn ) +happyIn21 x = unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> ([Symbol]) +happyOut21 x = unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (Category) -> (HappyAbsSyn ) +happyIn22 x = unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (Category) +happyOut22 x = unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x00\x00\x36\x00\x00\x00\x29\x00\x35\x00\x00\x00\x32\x00\x00\x00\x30\x00\x38\x00\x19\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x34\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x31\x00\xfd\xff\x00\x00\x2c\x00\x2a\x00\x23\x00\x22\x00\x2b\x00\x25\x00\x20\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x28\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x21\x00\x05\x00\x01\x00\x00\x00\x1d\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x02\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xf8\xff\x00\x00\xfe\xff\x00\x00\xfa\xff\xf7\xff\x00\x00\xf5\xff\xf2\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xf6\xff\xfb\xff\xf0\xff\x00\x00\x00\x00\xef\xff\x00\x00\xf4\xff\xf9\xff\x00\x00\xf1\xff\x00\x00\xed\xff\xe9\xff\x00\x00\xec\xff\xe8\xff\x00\x00\x00\x00\xe7\xff\x00\x00\xfd\xff\xed\xff\xee\xff\xeb\xff\xea\xff\xe8\xff\x00\x00\xe4\xff\xe2\xff\xf3\xff\xe5\xff\xe3\xff\xfc\xff\xe6\xff\xe1\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x06\x00\x02\x00\x03\x00\x03\x00\x03\x00\x07\x00\x0c\x00\x00\x00\x0a\x00\x00\x00\x08\x00\x01\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x12\x00\x12\x00\x0d\x00\x0e\x00\x0d\x00\x0e\x00\x01\x00\x0f\x00\x00\x00\x05\x00\x03\x00\x0c\x00\x00\x00\x09\x00\x05\x00\x0d\x00\x0c\x00\x09\x00\x07\x00\x0b\x00\x0f\x00\x0e\x00\x0f\x00\x04\x00\x08\x00\x06\x00\x04\x00\x0d\x00\x0f\x00\x08\x00\x07\x00\x03\x00\x06\x00\x02\x00\x0a\x00\x01\x00\x01\x00\x11\x00\x0b\x00\xff\xff\x0f\x00\x0c\x00\x0a\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x29\x00\x0c\x00\x1e\x00\x29\x00\x0c\x00\x0c\x00\x0c\x00\x09\x00\x03\x00\x1a\x00\x0a\x00\x1a\x00\x08\x00\x20\x00\x2a\x00\x30\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x1f\x00\x0d\x00\x25\x00\x1c\x00\x1b\x00\x1c\x00\x20\x00\x2f\x00\x0f\x00\x13\x00\x2e\x00\x18\x00\x07\x00\x14\x00\x05\x00\x23\x00\x03\x00\x10\x00\x27\x00\x11\x00\x21\x00\x2f\x00\x0f\x00\x03\x00\x28\x00\x04\x00\x29\x00\x23\x00\x0f\x00\x24\x00\x25\x00\x1f\x00\x1a\x00\x17\x00\x16\x00\x18\x00\x15\x00\xff\xff\x0c\x00\x00\x00\x0f\x00\x03\x00\x07\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (1, 31) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31) + ] + +happy_n_terms = 18 :: Int +happy_n_nonterms = 19 :: Int + +happyReduce_1 = happySpecReduce_1 0# happyReduction_1 +happyReduction_1 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> + happyIn4 + (Ident happy_var_1 + )} + +happyReduce_2 = happySpecReduce_1 1# happyReduction_2 +happyReduction_2 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> + happyIn5 + ((read happy_var_1) :: Integer + )} + +happyReduce_3 = happySpecReduce_1 2# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> + happyIn6 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_1 3# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (T_SingleQuoteString happy_var_1)) -> + happyIn7 + (SingleQuoteString (happy_var_1) + )} + +happyReduce_5 = happySpecReduce_1 4# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn8 + (Grammars (reverse happy_var_1) + )} + +happyReduce_6 = happyReduce 6# 5# happyReduction_6 +happyReduction_6 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut4 happy_x_2 of { happy_var_2 -> + case happyOut12 happy_x_3 of { happy_var_3 -> + case happyOut14 happy_x_4 of { happy_var_4 -> + happyIn9 + (Grammar happy_var_2 (reverse happy_var_3) (reverse happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_7 = happySpecReduce_0 6# happyReduction_7 +happyReduction_7 = happyIn10 + ([] + ) + +happyReduce_8 = happySpecReduce_2 6# happyReduction_8 +happyReduction_8 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn10 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_9 = happySpecReduce_2 7# happyReduction_9 +happyReduction_9 happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn11 + (StartCat happy_var_2 + )} + +happyReduce_10 = happySpecReduce_0 8# happyReduction_10 +happyReduction_10 = happyIn12 + ([] + ) + +happyReduce_11 = happySpecReduce_3 8# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn12 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_12 = happyReduce 7# 9# happyReduction_12 +happyReduction_12 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_3 of { happy_var_3 -> + case happyOut22 happy_x_5 of { happy_var_5 -> + case happyOut21 happy_x_7 of { happy_var_7 -> + happyIn13 + (Rule happy_var_1 happy_var_3 happy_var_5 happy_var_7 + ) `HappyStk` happyRest}}}} + +happyReduce_13 = happySpecReduce_0 10# happyReduction_13 +happyReduction_13 = happyIn14 + ([] + ) + +happyReduce_14 = happySpecReduce_3 10# happyReduction_14 +happyReduction_14 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn14 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_15 = happySpecReduce_1 11# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn15 + (Cons happy_var_1 + )} + +happyReduce_16 = happySpecReduce_1 11# happyReduction_16 +happyReduction_16 happy_x_1 + = happyIn15 + (Coerce + ) + +happyReduce_17 = happySpecReduce_3 12# happyReduction_17 +happyReduction_17 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn16 + (Profiles happy_var_2 + )} + +happyReduce_18 = happySpecReduce_0 13# happyReduction_18 +happyReduction_18 = happyIn17 + ([] + ) + +happyReduce_19 = happySpecReduce_1 13# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn17 + ((:[]) happy_var_1 + )} + +happyReduce_20 = happySpecReduce_3 13# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_3 of { happy_var_3 -> + happyIn17 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_21 = happySpecReduce_3 14# happyReduction_21 +happyReduction_21 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn18 + (UnifyProfile happy_var_2 + )} + +happyReduce_22 = happySpecReduce_1 14# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn18 + (ConstProfile happy_var_1 + )} + +happyReduce_23 = happySpecReduce_0 15# happyReduction_23 +happyReduction_23 = happyIn19 + ([] + ) + +happyReduce_24 = happySpecReduce_1 15# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn19 + ((:[]) happy_var_1 + )} + +happyReduce_25 = happySpecReduce_3 15# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn19 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_26 = happySpecReduce_1 16# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOut22 happy_x_1 of { happy_var_1 -> + happyIn20 + (CatS happy_var_1 + )} + +happyReduce_27 = happySpecReduce_1 16# happyReduction_27 +happyReduction_27 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn20 + (TermS happy_var_1 + )} + +happyReduce_28 = happySpecReduce_1 17# happyReduction_28 +happyReduction_28 happy_x_1 + = happyIn21 + ([] + ) + +happyReduce_29 = happySpecReduce_1 17# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn21 + ((:[]) happy_var_1 + )} + +happyReduce_30 = happySpecReduce_2 17# happyReduction_30 +happyReduction_30 happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn21 + ((:) happy_var_1 happy_var_2 + )}} + +happyReduce_31 = happySpecReduce_1 18# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn22 + (Category happy_var_1 + )} + +happyNewToken action sts stk [] = + happyDoAction 17# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + PT _ (TS ";") -> cont 1#; + PT _ (TS ":") -> cont 2#; + PT _ (TS ".") -> cont 3#; + PT _ (TS "->") -> cont 4#; + PT _ (TS "_") -> cont 5#; + PT _ (TS "[") -> cont 6#; + PT _ (TS "]") -> cont 7#; + PT _ (TS ",") -> cont 8#; + PT _ (TS "end") -> cont 9#; + PT _ (TS "grammar") -> cont 10#; + PT _ (TS "startcat") -> cont 11#; + PT _ (TV happy_dollar_dollar) -> cont 12#; + PT _ (TI happy_dollar_dollar) -> cont 13#; + PT _ (TL happy_dollar_dollar) -> cont 14#; + PT _ (T_SingleQuoteString happy_dollar_dollar) -> cont 15#; + _ -> cont 16#; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = (thenM) +happyReturn :: () => a -> Err a +happyReturn = (returnM) +happyThen1 m k tks = (thenM) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (returnM) a +happyError' :: () => [Token] -> Err a +happyError' = happyError + +pGrammars tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut8 x)) + +happySeq = happyDontSeq + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) + +myLexer = tokens +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: ParCFG.hs,v 1.8 2005/05/17 14:04:37 bringert Exp $ + + + + + + + + + + + + + +{-# LINE 27 "GenericTemplate.hs" #-} + + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 169 "GenericTemplate.hs" #-} + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src-3.0/GF/CFGM/ParCFG.y b/src-3.0/GF/CFGM/ParCFG.y new file mode 100644 index 000000000..7b3041b3b --- /dev/null +++ b/src-3.0/GF/CFGM/ParCFG.y @@ -0,0 +1,129 @@ +-- This Happy file was machine-generated by the BNF converter +{ +module ParCFG where +import AbsCFG +import LexCFG +import ErrM +} + +%name pGrammars Grammars + +-- no lexer declaration +%monad { Err } { thenM } { returnM } +%tokentype { Token } + +%token + ';' { PT _ (TS ";") } + ':' { PT _ (TS ":") } + '.' { PT _ (TS ".") } + '->' { PT _ (TS "->") } + '_' { PT _ (TS "_") } + '[' { PT _ (TS "[") } + ']' { PT _ (TS "]") } + ',' { PT _ (TS ",") } + 'end' { PT _ (TS "end") } + 'grammar' { PT _ (TS "grammar") } + 'startcat' { PT _ (TS "startcat") } + +L_ident { PT _ (TV $$) } +L_integ { PT _ (TI $$) } +L_quoted { PT _ (TL $$) } +L_SingleQuoteString { PT _ (T_SingleQuoteString $$) } +L_err { _ } + + +%% + +Ident :: { Ident } : L_ident { Ident $1 } +Integer :: { Integer } : L_integ { (read $1) :: Integer } +String :: { String } : L_quoted { $1 } +SingleQuoteString :: { SingleQuoteString} : L_SingleQuoteString { SingleQuoteString ($1)} + +Grammars :: { Grammars } +Grammars : ListGrammar { Grammars (reverse $1) } + + +Grammar :: { Grammar } +Grammar : 'grammar' Ident ListFlag ListRule 'end' 'grammar' { Grammar $2 (reverse $3) (reverse $4) } + + +ListGrammar :: { [Grammar] } +ListGrammar : {- empty -} { [] } + | ListGrammar Grammar { flip (:) $1 $2 } + + +Flag :: { Flag } +Flag : 'startcat' Category { StartCat $2 } + + +ListFlag :: { [Flag] } +ListFlag : {- empty -} { [] } + | ListFlag Flag ';' { flip (:) $1 $2 } + + +Rule :: { Rule } +Rule : Fun ':' Profiles '.' Category '->' ListSymbol { Rule $1 $3 $5 $7 } + + +ListRule :: { [Rule] } +ListRule : {- empty -} { [] } + | ListRule Rule ';' { flip (:) $1 $2 } + + +Fun :: { Fun } +Fun : Ident { Cons $1 } + | '_' { Coerce } + + +Profiles :: { Profiles } +Profiles : '[' ListProfile ']' { Profiles $2 } + + +ListProfile :: { [Profile] } +ListProfile : {- empty -} { [] } + | Profile { (:[]) $1 } + | Profile ',' ListProfile { (:) $1 $3 } + + +Profile :: { Profile } +Profile : '[' ListInteger ']' { UnifyProfile $2 } + | Ident { ConstProfile $1 } + + +ListInteger :: { [Integer] } +ListInteger : {- empty -} { [] } + | Integer { (:[]) $1 } + | Integer ',' ListInteger { (:) $1 $3 } + + +Symbol :: { Symbol } +Symbol : Category { CatS $1 } + | String { TermS $1 } + + +ListSymbol :: { [Symbol] } +ListSymbol : '.' { [] } + | Symbol { (:[]) $1 } + | Symbol ListSymbol { (:) $1 $2 } + + +Category :: { Category } +Category : SingleQuoteString { Category $1 } + + + +{ + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) + +myLexer = tokens +} + diff --git a/src-3.0/GF/CFGM/PrintCFG.hs b/src-3.0/GF/CFGM/PrintCFG.hs new file mode 100644 index 000000000..0fd46239c --- /dev/null +++ b/src-3.0/GF/CFGM/PrintCFG.hs @@ -0,0 +1,157 @@ +module GF.CFGM.PrintCFG where + +-- pretty-printer generated by the BNF converter + +import GF.CFGM.AbsCFG +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + "[" :ts -> showChar '[' . rend i ts + "(" :ts -> showChar '(' . rend i ts + "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts + "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts + "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts + ";" :ts -> showChar ';' . new i . rend i ts + t : "," :ts -> showString t . space "," . rend i ts + t : ")" :ts -> showString t . showChar ')' . rend i ts + t : "]" :ts -> showString t . showChar ']' . rend i ts + t :ts -> space t . rend i ts + _ -> id + new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace + space t = showString t . (\s -> if null s then "" else (' ':s)) + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- the printer class does the job +class Print a where + prt :: Int -> a -> Doc + prtList :: [a] -> Doc + prtList = concatD . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') + prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q s = case s of + _ | s == q -> showChar '\\' . showChar s + '\\'-> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + _ -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + +instance Print Double where + prt _ x = doc (shows x) + + +instance Print Ident where + prt _ (Ident i) = doc (showString i) + + +instance Print SingleQuoteString where + prt _ (SingleQuoteString i) = doc (showString i) + + + +instance Print Grammars where + prt i e = case e of + Grammars grammars -> prPrec i 0 (concatD [prt 0 grammars]) + + +instance Print Grammar where + prt i e = case e of + Grammar id flags rules -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 id , prt 0 flags , prt 0 rules , doc (showString "end") , doc (showString "grammar")]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Flag where + prt i e = case e of + StartCat category -> prPrec i 0 (concatD [doc (showString "startcat") , prt 0 category]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Rule where + prt i e = case e of + Rule fun profiles category symbols -> prPrec i 0 (concatD [prt 0 fun , doc (showString ":") , prt 0 profiles , doc (showString ".") , prt 0 category , doc (showString "->") , prt 0 symbols]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Fun where + prt i e = case e of + Cons id -> prPrec i 0 (concatD [prt 0 id]) + Coerce -> prPrec i 0 (concatD [doc (showString "_")]) + + +instance Print Profiles where + prt i e = case e of + Profiles profiles -> prPrec i 0 (concatD [doc (showString "[") , prt 0 profiles , doc (showString "]")]) + + +instance Print Profile where + prt i e = case e of + UnifyProfile ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")]) + ConstProfile id -> prPrec i 0 (concatD [prt 0 id]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Symbol where + prt i e = case e of + CatS category -> prPrec i 0 (concatD [prt 0 category]) + TermS str -> prPrec i 0 (concatD [prt 0 str]) + + prtList es = case es of + [] -> (concatD [doc (showString ".")]) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Category where + prt i e = case e of + Category singlequotestring -> prPrec i 0 (concatD [prt 0 singlequotestring]) + + + diff --git a/src-3.0/GF/CFGM/PrintCFGrammar.hs b/src-3.0/GF/CFGM/PrintCFGrammar.hs new file mode 100644 index 000000000..a68d2325c --- /dev/null +++ b/src-3.0/GF/CFGM/PrintCFGrammar.hs @@ -0,0 +1,113 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrintCFGrammar +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/17 14:04:38 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.20 $ +-- +-- Handles printing a CFGrammar in CFGM format. +----------------------------------------------------------------------------- + +module GF.CFGM.PrintCFGrammar (prCanonAsCFGM) where + +import GF.Canon.AbsGFC +import qualified GF.CFGM.PrintCFG as PrintCFG +import GF.Infra.Ident +import GF.Canon.GFC +import GF.Infra.Modules + +import qualified GF.Conversion.GFC as Cnv +import GF.Infra.Print (prt) +import GF.Formalism.CFG (CFRule(..)) +import qualified GF.Formalism.Utilities as GU +import qualified GF.Conversion.Types as GT +import qualified GF.CFGM.AbsCFG as AbsCFG +import GF.Formalism.Utilities (Symbol(..)) + +import GF.Data.ErrM +import GF.Data.Utilities (compareBy) +import qualified GF.Infra.Option as Option + +import Data.List (intersperse, sortBy) +import Data.Maybe (listToMaybe, maybeToList, maybe) + +import GF.Infra.Print +import GF.System.Tracing + +-- | FIXME: should add an Options argument, +-- to be able to decide which CFG conversion one wants to use +prCanonAsCFGM :: Option.Options -> CanonGrammar -> String +prCanonAsCFGM opts gr = unlines $ map (prLangAsCFGM gr) xs + where + cncs = maybe [] (allConcretes gr) (greatestAbstract gr) + cncms = map (\i -> (i,fromOk (lookupModule gr i))) cncs + fromOk (Ok x) = x + fromOk (Bad y) = error y + xs = tracePrt "CFGM languages" (prtBefore "\n") + [ (i, getFlag fs "startcat", getFlag fs "conversion") | + (i, ModMod (Module{flags=fs})) <- cncms ] + +-- | FIXME: need to look in abstract module too +getFlag :: [Flag] -> String -> Maybe String +getFlag fs x = listToMaybe [v | Flg (IC k) (IC v) <- fs, k == x] + +-- FIXME: (1) Should use 'ShellState.stateCFG' +-- instead of 'Cnv.gfc2cfg' (which recalculates the grammar every time) +-- +-- FIXME: (2) Should use the state options, when calculating the CFG +-- (this is solved automatically if one solves (1) above) +prLangAsCFGM :: CanonGrammar -> (Ident, Maybe String, Maybe String) -> String +prLangAsCFGM gr (i, start, cnv) = prCFGrammarAsCFGM (Cnv.gfc2cfg opts (gr, i)) i start +-- prLangAsCFGM gr i start = prCFGrammarAsCFGM (Cnv.cfg (Cnv.pInfo opts gr i)) i start + where opts = Option.Opts $ maybeToList $ fmap Option.gfcConversion cnv + +prCFGrammarAsCFGM :: GT.CGrammar -> Ident -> Maybe String -> String +prCFGrammarAsCFGM gr i start = PrintCFG.printTree $ cfGrammarToCFGM gr i start + +cfGrammarToCFGM :: GT.CGrammar -> Ident -> Maybe String -> AbsCFG.Grammar +cfGrammarToCFGM gr i start = + AbsCFG.Grammar (identToCFGMIdent i) flags $ sortCFGMRules $ map ruleToCFGMRule gr + where flags = maybe [] (\c -> [AbsCFG.StartCat $ strToCFGMCat (c++"{}.s")]) start + sortCFGMRules = sortBy (compareBy ruleKey) + ruleKey (AbsCFG.Rule f ps cat rhs) = (cat,f) + +ruleToCFGMRule :: GT.CRule -> AbsCFG.Rule +ruleToCFGMRule (CFRule c rhs (GU.Name fun profile)) + = AbsCFG.Rule fun' p' c' rhs' + where + fun' = identToFun fun + p' = profileToCFGMProfile profile + c' = catToCFGMCat c + rhs' = map symbolToGFCMSymbol rhs + +profileToCFGMProfile :: [GU.Profile (GU.SyntaxForest GT.Fun)] -> AbsCFG.Profiles +profileToCFGMProfile = AbsCFG.Profiles . map cnvProfile + where cnvProfile (GU.Unify ns) = AbsCFG.UnifyProfile $ map fromIntegral ns + -- FIXME: is it always FNode? + cnvProfile (GU.Constant (GU.FNode c _)) = AbsCFG.ConstProfile $ identToCFGMIdent c + + +identToCFGMIdent :: Ident -> AbsCFG.Ident +identToCFGMIdent = AbsCFG.Ident . prt + +identToFun :: Ident -> AbsCFG.Fun +identToFun IW = AbsCFG.Coerce +identToFun i = AbsCFG.Cons (identToCFGMIdent i) + +strToCFGMCat :: String -> AbsCFG.Category +strToCFGMCat = AbsCFG.Category . AbsCFG.SingleQuoteString . quoteSingle + +catToCFGMCat :: GT.CCat -> AbsCFG.Category +catToCFGMCat = strToCFGMCat . prt + +symbolToGFCMSymbol :: Symbol GT.CCat GT.Token -> AbsCFG.Symbol +symbolToGFCMSymbol (Cat c) = AbsCFG.CatS (catToCFGMCat c) +symbolToGFCMSymbol (Tok t) = AbsCFG.TermS (prt t) + +quoteSingle :: String -> String +quoteSingle s = "'" ++ escapeSingle s ++ "'" + where escapeSingle = concatMap (\c -> if c == '\'' then "\\'" else [c]) diff --git a/src-3.0/GF/Canon/AbsGFC.hs b/src-3.0/GF/Canon/AbsGFC.hs new file mode 100644 index 000000000..8ce719104 --- /dev/null +++ b/src-3.0/GF/Canon/AbsGFC.hs @@ -0,0 +1,182 @@ +module GF.Canon.AbsGFC where + +import GF.Infra.Ident --H + +-- Haskell module generated by the BNF converter, except --H + +-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H + +data Canon = + MGr [Ident] Ident [Module] + | Gr [Module] + deriving (Eq,Ord,Show) + +data Line = + LMulti [Ident] Ident + | LHeader ModType Extend Open + | LFlag Flag + | LDef Def + | LEnd + deriving (Eq,Ord,Show) + +data Module = + Mod ModType Extend Open [Flag] [Def] + deriving (Eq,Ord,Show) + +data ModType = + MTAbs Ident + | MTCnc Ident Ident + | MTRes Ident + | MTTrans Ident Ident Ident + deriving (Eq,Ord,Show) + +data Extend = + Ext [Ident] + | NoExt + deriving (Eq,Ord,Show) + +data Open = + Opens [Ident] + | NoOpens + deriving (Eq,Ord,Show) + +data Flag = + Flg Ident Ident + deriving (Eq,Ord,Show) + +data Def = + AbsDCat Ident [Decl] [CIdent] + | AbsDFun Ident Exp Exp + | AbsDTrans Ident Exp + | ResDPar Ident [ParDef] + | ResDOper Ident CType Term + | CncDCat Ident CType Term Term + | CncDFun Ident CIdent [ArgVar] Term Term + | AnyDInd Ident Status Ident + deriving (Eq,Ord,Show) + +data ParDef = + ParD Ident [CType] + deriving (Eq,Ord,Show) + +data Status = + Canon + | NonCan + deriving (Eq,Ord,Show) + +data CIdent = + CIQ Ident Ident + deriving (Eq,Ord,Show) + +data Exp = + EApp Exp Exp + | EProd Ident Exp Exp + | EAbs Ident Exp + | EAtom Atom + | EData + | EEq [Equation] + deriving (Eq,Ord,Show) + +data Sort = + SType + deriving (Eq,Ord,Show) + +data Equation = + Equ [APatt] Exp + deriving (Eq,Ord,Show) + +data APatt = + APC CIdent [APatt] + | APV Ident + | APS String + | API Integer + | APF Double + | APW + deriving (Eq,Ord,Show) + +data Atom = + AC CIdent + | AD CIdent + | AV Ident + | AM Integer + | AS String + | AI Integer + | AF Double + | AT Sort + deriving (Eq,Ord,Show) + +data Decl = + Decl Ident Exp + deriving (Eq,Ord,Show) + +data CType = + RecType [Labelling] + | Table CType CType + | Cn CIdent + | TStr + | TInts Integer + deriving (Eq,Ord,Show) + +data Labelling = + Lbg Label CType + deriving (Eq,Ord,Show) + +data Term = + Arg ArgVar + | I CIdent + | Par CIdent [Term] + | LI Ident + | R [Assign] + | P Term Label + | T CType [Case] + | V CType [Term] + | S Term Term + | C Term Term + | FV [Term] + | EInt Integer + | EFloat Double + | K Tokn + | E + deriving (Eq,Ord,Show) + +data Tokn = + KS String + | KP [String] [Variant] + | KM String + deriving (Eq,Ord,Show) + +data Assign = + Ass Label Term + deriving (Eq,Ord,Show) + +data Case = + Cas [Patt] Term + deriving (Eq,Ord,Show) + +data Variant = + Var [String] [String] + deriving (Eq,Ord,Show) + +data Label = + L Ident + | LV Integer + deriving (Eq,Ord,Show) + +data ArgVar = + A Ident Integer + | AB Ident Integer Integer + deriving (Eq,Ord,Show) + +data Patt = + PC CIdent [Patt] + | PV Ident + | PW + | PR [PattAssign] + | PI Integer + | PF Double + deriving (Eq,Ord,Show) + +data PattAssign = + PAss Label Patt + deriving (Eq,Ord,Show) + diff --git a/src-3.0/GF/Canon/AbsToBNF.hs b/src-3.0/GF/Canon/AbsToBNF.hs new file mode 100644 index 000000000..e30e836da --- /dev/null +++ b/src-3.0/GF/Canon/AbsToBNF.hs @@ -0,0 +1,38 @@ +module GF.Canon.AbsToBNF where + +import GF.Grammar.SGrammar +import GF.Data.Operations +import GF.Infra.Option +import GF.Canon.GFC (CanonGrammar) + +-- AR 10/5/2007 + +abstract2bnf :: CanonGrammar -> String +abstract2bnf = sgrammar2bnf . gr2sgr noOptions emptyProbs + +sgrammar2bnf :: SGrammar -> String +sgrammar2bnf = unlines . map (prBNFRule . mkBNF) . allRules + +prBNFRule :: BNFRule -> String +prBNFRule = id + +type BNFRule = String + +mkBNF :: SRule -> BNFRule +mkBNF (pfun,(args,cat)) = + fun ++ "." +++ gfId cat +++ "::=" +++ rhs +++ ";" + where + fun = gfId (snd pfun) + rhs = case args of + [] -> prQuotedString (snd pfun) + _ -> unwords (map gfId args) + +-- good for GF +gfId i = i + +-- good for BNFC +gfIdd i = case i of + "Int" -> "Integer" + "String" -> i + "Float" -> "Double" + _ -> "G" ++ i ++ "_" diff --git a/src-3.0/GF/Canon/CMacros.hs b/src-3.0/GF/Canon/CMacros.hs new file mode 100644 index 000000000..572f09763 --- /dev/null +++ b/src-3.0/GF/Canon/CMacros.hs @@ -0,0 +1,334 @@ +---------------------------------------------------------------------- +-- | +-- Module : CMacros +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:41 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.29 $ +-- +-- Macros for building and analysing terms in GFC concrete syntax. +-- +-- macros for concrete syntax in GFC that do not need lookup in a grammar +----------------------------------------------------------------------------- + +module GF.Canon.CMacros where + +import GF.Infra.Ident +import GF.Canon.AbsGFC +import GF.Canon.GFC +import qualified GF.Infra.Ident as A ---- no need to qualif? 21/9 +import qualified GF.Grammar.Values as V +import qualified GF.Grammar.MMacros as M +import GF.Grammar.PrGrammar +import GF.Data.Str + +import GF.Data.Operations + +import Data.Char +import Control.Monad + +-- | how to mark subtrees, dep. on node, position, whether focus +type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String) + +-- | also to process the text (needed for escapes e.g. in XML) +type Marker = (JustMarker, Maybe (String -> String)) + +defTMarker :: JustMarker -> Marker +defTMarker = flip (curry id) Nothing + +markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term +markSubtree (mk,esc) n is = markSubterm esc . mk n is + +escapeMkString :: Marker -> Maybe (String -> String) +escapeMkString = snd + +-- | if no marking is wanted, use the following +noMark :: Marker +noMark = defTMarker mk where + mk _ _ _ = ("","") + +-- | mark metas with their categories +metaCatMark :: Marker +metaCatMark = defTMarker mk where + mk nod _ _ = case nod of + V.N (_,V.AtM _,val,_,_) -> ("", '+':prt val) + _ -> ("","") + +-- | for vanilla brackets, focus, and position, use +markBracket :: Marker +markBracket = defTMarker mk where + mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]") + +-- | for focus only +markFocus :: Marker +markFocus = defTMarker mk where + mk n p b = if b then ("[*","*]") else ("","") + +-- | for XML, use +markJustXML :: JustMarker +markJustXML n i b = + if b + then ("", "") + else ("", "") + where + c = "type=" ++ prt (M.valNode n) + p = "position=" ++ (show $ reverse i) + s = if (null (M.constrsNode n)) then "" else " status=incorrect" + +markXML :: Marker +markXML = (markJustXML, Just esc) where + esc s = case s of + '\\':'<':cs -> '\\':'<':esc cs + '\\':'>':cs -> '\\':'>':esc cs + '\\':'\\':cs -> '\\':'\\':esc cs + ----- the first 3 needed because marking may revisit; needs to be fixed + + '<':cs -> '\\':'<':esc cs + '>':cs -> '\\':'>':esc cs + '\\':cs -> '\\':'\\':esc cs + c :cs -> c :esc cs + _ -> s + +-- | for XML in JGF 1, use +markXMLjgf :: Marker +markXMLjgf = defTMarker mk where + mk n p b = + if b + then ("", "") + else ("","") + where + c = "type=" ++ prt (M.valNode n) + +-- | the marking engine +markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term +markSubterm esc (beg, end) t = case t of + R rs -> R $ map markField rs + T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs] + FV ts -> FV $ map mark ts + _ -> foldr1 C (tm beg ++ [mkEscIf t] ++ tm end) -- t : Str guaranteed? + where + mark = markSubterm esc (beg, end) + markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt + tm s = if null s then [] else [tM s] + mkEscIf t = case esc of + Just f -> mkEsc f t + _ -> t + mkEsc f t = case t of + K (KS s) -> K (KS (f s)) + C u v -> C (mkEsc f u) (mkEsc f v) + FV ts -> FV (map (mkEsc f) ts) + _ -> t ---- do we need to look at other cases? + +tK,tM :: String -> Term +tK = K . KS +tM = K . KM + +term2patt :: Term -> Err Patt +term2patt trm = case trm of + Par c aa -> do + aa' <- mapM term2patt aa + return (PC c aa') + R r -> do + let (ll,aa) = unzip [(l,a) | Ass l a <- r] + aa' <- mapM term2patt aa + return (PR (map (uncurry PAss) (zip ll aa'))) + LI x -> return $ PV x + EInt i -> return $ PI i + EFloat i -> return $ PF i + FV (t:_) -> term2patt t ---- + _ -> prtBad "no pattern corresponds to term" trm + +patt2term :: Patt -> Term +patt2term p = case p of + PC x ps -> Par x (map patt2term ps) + PV x -> LI x + PW -> anyTerm ---- + PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ] + PI i -> EInt i + PF i -> EFloat i + +anyTerm :: Term +anyTerm = LI (A.identC "_") --- should not happen + +matchPatt :: [Case] -> Term -> Err Term +matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts +matchPatt cs0 trm = term2patt trm >>= match cs0 where + match cs t = + case cs of + Cas ps b :_ | elem t ps -> return b + _:cs' -> match cs' t + [] -> Bad $ "pattern not found for" +++ prt t + +++ "among" ++++ unlines (map prt cs0) ---- debug + +defLinType :: CType +defLinType = RecType [Lbg (L (A.identC "s")) TStr] + +defLindef :: Term +defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))] + +isDiscontinuousCType :: CType -> Bool +isDiscontinuousCType t = case t of + RecType rs -> length [t | Lbg _ t <- rs, valTableType t == TStr] > 1 + _ -> True --- does not occur; would not behave well in lin commands + +valTableType :: CType -> CType +valTableType t = case t of + Table _ v -> valTableType v + _ -> t + +strsFromTerm :: Term -> Err [Str] +strsFromTerm t = case t of + K (KS s) -> return [str s] + K (KM s) -> return [str s] + K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]] + C s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [plusStr x y | x <- s', y <- t'] + FV ts -> liftM concat $ mapM strsFromTerm ts + E -> return [str []] + _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug +---- _ -> prtBad "cannot get Str from term " t + +-- | recursively collect all branches in a table +allInTable :: Term -> [Term] +allInTable t = case t of + T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ? + _ -> [t] + +-- | to gather s-fields; assumes term in normal form, preserves label +allLinFields :: Term -> Err [[(Label,Term)]] +allLinFields trm = case trm of +---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good + R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad + FV ts -> do + lts <- mapM allLinFields ts + return $ concat lts + + T _ ts -> liftM concat $ mapM allLinFields [t | Cas _ t <- ts] + V _ ts -> liftM concat $ mapM allLinFields ts + S t _ -> allLinFields t + + _ -> prtBad "fields can only be sought in a record not in" trm + +-- | deprecated +isLinLabel :: Label -> Bool +isLinLabel l = case l of + L (A.IC ('s':cs)) | all isDigit cs -> True + -- peb (28/4-04), for MCFG grammars to work: + L (A.IC cs) | null cs || head cs `elem` ".!" -> True + _ -> False + +-- | to gather ultimate cases in a table; preserves pattern list +allCaseValues :: Term -> [([Patt],Term)] +allCaseValues trm = case trm of + T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0] + _ -> [([],trm)] + +-- | to gather all linearizations; assumes normal form, preserves label and args +allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] +allLinValues trm = do + lts <- allLinFields trm + mapM (mapPairsM (return . allCaseValues)) lts + +-- | to gather all fields; does not assume s naming of fields; +-- used in Morpho only +allAllLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] +allAllLinValues trm = do + lts <- allFields trm + mapM (mapPairsM (return . allCaseValues)) lts + where + allFields trm = case trm of + R rs -> return [[(l,t) | Ass l t <- rs]] + FV ts -> do + lts <- mapM allFields ts + return $ concat lts + _ -> prtBad "fields can only be sought in a record not in" trm + +-- | to gather all linearizations, even from nested records; params ignored +allLinBranches :: Term -> [([Label],Term)] +allLinBranches trm = case trm of + R rs -> [(l:ls,u) | Ass l t <- rs, (ls,u) <- allLinBranches t] + FV ts -> concatMap allLinBranches ts + T _ ts -> concatMap allLinBranches [t | Cas _ t <- ts] + V _ ts -> concatMap allLinBranches ts + _ -> [([],trm)] + +redirectIdent :: A.Ident -> CIdent -> CIdent +redirectIdent n f@(CIQ _ c) = CIQ n c + +ciq :: A.Ident -> A.Ident -> CIdent +ciq n f = CIQ n f + +wordsInTerm :: Term -> [String] +wordsInTerm trm = filter (not . null) $ case trm of + K (KS s) -> [s] + S c _ -> wo c + R rs -> concat [wo t | Ass _ t <- rs] + T _ cs -> concat [wo t | Cas _ t <- cs] + V _ cs -> concat [wo t | t <- cs] + C s t -> wo s ++ wo t + FV ts -> concatMap wo ts + K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs] + P t _ -> wo t --- not needed ? + _ -> [] + where wo = wordsInTerm + +onTokens :: (String -> String) -> Term -> Term +onTokens f t = case t of + K (KS s) -> K (KS (f s)) + K (KP ss vs) -> K (KP (map f ss) [Var (map f x) (map f y) | Var x y <- vs]) + _ -> composSafeOp (onTokens f) t + +-- | to define compositional term functions +composSafeOp :: (Term -> Term) -> Term -> Term +composSafeOp op trm = case composOp (mkMonadic op) trm of + Ok t -> t + _ -> error "the operation is safe isn't it ?" + where + mkMonadic f = return . f + +-- | to define compositional term functions +composOp :: Monad m => (Term -> m Term) -> Term -> m Term +composOp co trm = + case trm of + Par x as -> + do + as' <- mapM co as + return (Par x as') + R as -> + do + let onAss (Ass l t) = liftM (Ass l) (co t) + as' <- mapM onAss as + return (R as') + P a x -> + do + a' <- co a + return (P a' x) + T x as -> + do + let onCas (Cas ps t) = liftM (Cas ps) (co t) + as' <- mapM onCas as + return (T x as') + S a b -> + do + a' <- co a + b' <- co b + return (S a' b') + C a b -> + do + a' <- co a + b' <- co b + return (C a' b') + FV as -> + do + as' <- mapM co as + return (FV as') + V x as -> + do + as' <- mapM co as + return (V x as') + _ -> return trm -- covers Arg, I, LI, K, E diff --git a/src-3.0/GF/Canon/CanonToGFCC.hs b/src-3.0/GF/Canon/CanonToGFCC.hs new file mode 100644 index 000000000..044ea3669 --- /dev/null +++ b/src-3.0/GF/Canon/CanonToGFCC.hs @@ -0,0 +1,45 @@ +module GF.Canon.CanonToGFCC where + +import GF.Devel.GrammarToGFCC +import GF.Devel.PrintGFCC +import GF.GFCC.CheckGFCC (checkGFCCmaybe) +import GF.GFCC.OptimizeGFCC +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.CanonToGrammar +import GF.Canon.Subexpressions +import GF.Devel.PrintGFCC +import GF.Grammar.PrGrammar + +import qualified GF.Infra.Modules as M +import GF.Infra.Option + +import GF.Data.Operations +import GF.Text.UTF8 + +canon2gfccPr opts = printGFCC . canon2gfcc opts +canon2gfcc opts = source2gfcc opts . canon2source ---- +canon2source = err error id . canon2sourceGrammar . unSubelimCanon + +source2gfcc opts gf = + let + (abs,gfcc) = mkCanon2gfcc opts (gfcabs gf) gf + gfcc1 = maybe undefined id $ checkGFCCmaybe gfcc + in addParsers $ if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1 + +gfcabs gfc = + prt $ head $ M.allConcretes gfc $ maybe (error "no abstract") id $ + M.greatestAbstract gfc + +{- +-- this variant makes utf8 conversion; used in back ends +mkCanon2gfcc :: CanonGrammar -> D.GFCC +mkCanon2gfcc = +-- canon2gfcc . reorder abs . utf8Conv . canon2canon abs + optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize + +-- this variant makes no utf8 conversion; used in ShellState +mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC +mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize +-} + diff --git a/src-3.0/GF/Canon/CanonToGrammar.hs b/src-3.0/GF/Canon/CanonToGrammar.hs new file mode 100644 index 000000000..078c3cc03 --- /dev/null +++ b/src-3.0/GF/Canon/CanonToGrammar.hs @@ -0,0 +1,203 @@ +---------------------------------------------------------------------- +-- | +-- Module : CanonToGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:17 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.15 $ +-- +-- a decompiler. AR 12/6/2003 -- 19/4/2004 +----------------------------------------------------------------------------- + +module GF.Canon.CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where + +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.MkGFC +---import CMacros +import qualified GF.Infra.Modules as M +import qualified GF.Infra.Option as O +import qualified GF.Grammar.Grammar as G +import qualified GF.Grammar.Macros as F + +import GF.Infra.Ident +import GF.Data.Operations + +import Control.Monad + +canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar +canon2sourceGrammar gr = do + ms' <- mapM canon2sourceModule $ M.modules gr + return $ M.MGrammar ms' + +canon2sourceModule :: CanonModule -> Err G.SourceModule +canon2sourceModule (i,mi) = do + i' <- redIdent i + info' <- case mi of + M.ModMod m -> do + (e,os) <- redExtOpen m + flags <- mapM redFlag $ M.flags m + (abstr,mt) <- case M.mtype m of + M.MTConcrete a -> do + a' <- redIdent a + return (a', M.MTConcrete a') + M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed + M.MTResource -> return (i',M.MTResource) --- c' not needed + M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed + defs <- mapMTree redInfo $ M.jments m + return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs + _ -> Bad $ "cannot decompile module type" + return (i',info') + where + redExtOpen m = do + e' <- return $ M.extend m + os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $ + M.opens m + return (e',os') + +redInfo :: (Ident,Info) -> Err (Ident,G.Info) +redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do + c' <- redIdent c + info' <- case info of + AbsCat cont fs -> do + return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs)) + AbsFun typ df -> do + return $ G.AbsFun (Yes typ) (Yes df) + AbsTrans t -> do + return $ G.AbsTrans t + + ResPar par -> do + par' <- mapM redParam par + return $ G.ResParam (Yes (par',Nothing)) ---- list of values + + ResOper pty ptr -> do + ty' <- redCType pty + trm' <- redCTerm ptr + return $ G.ResOper (Yes ty') (Yes trm') + + CncCat pty ptr ppr -> do + ty' <- redCType pty + trm' <- redCTerm ptr + ppr' <- redCTerm ppr + return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr') + CncFun (CIQ abstr cat) xx body ppr -> do + xx' <- mapM redArgVar xx + body' <- redCTerm body + ppr' <- redCTerm ppr + cat' <- redIdent cat + return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing + (Yes (F.mkAbs xx' body')) (Yes ppr') + + AnyInd b c -> liftM (G.AnyInd b) $ redIdent c + + return (c',info') + +redQIdent :: CIdent -> Err G.QIdent +redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c) + +redIdent :: Ident -> Err Ident +redIdent = return + +redFlag :: Flag -> Err O.Option +redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x]) + +redDecl :: Decl -> Err G.Decl +redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a) + +redType :: Exp -> Err G.Type +redType = redTerm + +redTerm :: Exp -> Err G.Term +redTerm t = return $ trExp t + +-- resource + +redParam (ParD c cont) = do + c' <- redIdent c + cont' <- mapM redCType cont + return $ (c', [(IW,t) | t <- cont']) + +-- concrete syntax + +redCType :: CType -> Err G.Type +redCType t = case t of + RecType lbs -> do + let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs] + ls' = map redLabel ls + ts' <- mapM redCType ts + return $ G.RecType $ zip ls' ts' + Table p v -> liftM2 G.Table (redCType p) (redCType v) + Cn mc -> liftM (uncurry G.QC) $ redQIdent mc + TStr -> return $ F.typeStr + TInts i -> return $ F.typeInts (fromInteger i) + +redCTerm :: Term -> Err G.Term +redCTerm x = case x of + Arg argvar -> liftM G.Vr $ redArgVar argvar + I cident -> liftM (uncurry G.Q) $ redQIdent cident + Par cident terms -> liftM2 F.mkApp + (liftM (uncurry G.QC) $ redQIdent cident) + (mapM redCTerm terms) + LI id -> liftM G.Vr $ redIdent id + R assigns -> do + let (ls,ts) = unzip [(l,t) | Ass l t <- assigns] + let ls' = map redLabel ls + ts' <- mapM redCTerm ts + return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts'] + P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label) + T ctype cases -> do + ctype' <- redCType ctype + let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases] + ps' <- mapM redPatt ps + ts' <- mapM redCTerm ts + let tinfo = case ps' of + [G.PV _] -> G.TTyped ctype' + _ -> G.TComp ctype' + return $ G.T tinfo $ zip ps' ts' + V ctype ts -> do + ctype' <- redCType ctype + ts' <- mapM redCTerm ts + return $ G.V ctype' ts' + S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term) + C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term) + FV terms -> liftM G.FV $ mapM redCTerm terms + K (KS str) -> return $ G.K str + EInt i -> return $ G.EInt i + EFloat i -> return $ G.EFloat i + E -> return $ G.Empty + K (KP d vs) -> return $ + G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs]) + where + tList ss = case ss of --- this should be in Macros + [] -> G.Empty + _ -> foldr1 G.C $ map G.K ss + +failure x = Bad $ "not yet" +++ show x ---- + +redArgVar :: ArgVar -> Err Ident +redArgVar x = case x of + A x i -> return $ IA (prIdent x, fromInteger i) + AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i) + +redLabel :: Label -> G.Label +redLabel (L x) = G.LIdent $ prIdent x +redLabel (LV i) = G.LVar $ fromInteger i + +redPatt :: Patt -> Err G.Patt +redPatt p = case p of + PV x -> liftM G.PV $ redIdent x + PC mc ps -> do + (m,c) <- redQIdent mc + liftM (G.PP m c) (mapM redPatt ps) + PR rs -> do + let (ls,ts) = unzip [(l,t) | PAss l t <- rs] + ls' = map redLabel ls + ts <- mapM redPatt ts + return $ G.PR $ zip ls' ts + PI i -> return $ G.PInt i + PF i -> return $ G.PFloat i + _ -> Bad $ "cannot recompile pattern" +++ show p + diff --git a/src-3.0/GF/Canon/GFC.cf b/src-3.0/GF/Canon/GFC.cf new file mode 100644 index 000000000..d9385a49f --- /dev/null +++ b/src-3.0/GF/Canon/GFC.cf @@ -0,0 +1,170 @@ +-- top-level grammar + +-- Canonical GF. AR 27/4/2003 + +entrypoints Canon, Line ; + +-- old approach: read in a whole grammar + +MGr. Canon ::= "grammar" [Ident] "of" Ident ";" [Module] ; +Gr. Canon ::= [Module] ; + +-- new approach: read line by line + +LMulti. Line ::= "grammar" [Ident] "of" Ident ";" ; +LHeader. Line ::= ModType "=" Extend Open "{" ; +LFlag. Line ::= Flag ";" ; +LDef. Line ::= Def ";" ; +LEnd. Line ::= "}" ; + +Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ; + +MTAbs. ModType ::= "abstract" Ident ; +MTCnc. ModType ::= "concrete" Ident "of" Ident ; +MTRes. ModType ::= "resource" Ident ; +MTTrans. ModType ::= "transfer" Ident ":" Ident "->" Ident ; + +separator Module "" ; + +Ext. Extend ::= [Ident] "**" ; +NoExt. Extend ::= ; + +Opens. Open ::= "open" [Ident] "in" ; +NoOpens. Open ::= ; + + +-- judgements + +Flg. Flag ::= "flags" Ident "=" Ident ; --- to have the same res word as in GF + +AbsDCat. Def ::= "cat" Ident "[" [Decl] "]" "=" [CIdent] ; +AbsDFun. Def ::= "fun" Ident ":" Exp "=" Exp ; +AbsDTrans. Def ::= "transfer" Ident "=" Exp ; + +ResDPar. Def ::= "param" Ident "=" [ParDef] ; +ResDOper. Def ::= "oper" Ident ":" CType "=" Term ; + +CncDCat. Def ::= "lincat" Ident "=" CType "=" Term ";" Term ; +CncDFun. Def ::= "lin" Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ; + +AnyDInd. Def ::= Ident Status "in" Ident ; + +ParD. ParDef ::= Ident [CType] ; + +-- the canonicity of an indirected constant + +Canon. Status ::= "data" ; +NonCan. Status ::= ; + +-- names originating from resource modules: prefixed by the module name + +CIQ. CIdent ::= Ident "." Ident ; + +-- types and terms in abstract syntax; no longer type-annotated + +EApp. Exp1 ::= Exp1 Exp2 ; +EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ; +EAbs. Exp ::= "\\" Ident "->" Exp ; +EAtom. Exp2 ::= Atom ; +EData. Exp2 ::= "data" ; + +EEq. Exp ::= "{" [Equation] "}" ; -- list of pattern eqs; primitive notion: [] + +coercions Exp 2 ; + +SType. Sort ::= "Type" ; + +Equ. Equation ::= [APatt] "->" Exp ; + +APC. APatt ::= "(" CIdent [APatt] ")" ; +APV. APatt ::= Ident ; +APS. APatt ::= String ; +API. APatt ::= Integer ; +APF. APatt ::= Double ; +APW. APatt ::= "_" ; + +separator Decl ";" ; +terminator APatt "" ; +terminator Equation ";" ; + +AC. Atom ::= CIdent ; +AD. Atom ::= "<" CIdent ">" ; +AV. Atom ::= "$" Ident ; +AM. Atom ::= "?" Integer ; +AS. Atom ::= String ; +AI. Atom ::= Integer ; +AT. Atom ::= Sort ; + +Decl. Decl ::= Ident ":" Exp ; + + +-- types, terms, and patterns in concrete syntax + +RecType. CType ::= "{" [Labelling] "}" ; +Table. CType ::= "(" CType "=>" CType ")" ; +Cn. CType ::= CIdent ; +TStr. CType ::= "Str" ; +TInts. CType ::= "Ints" Integer ; + +Lbg. Labelling ::= Label ":" CType ; + +Arg. Term2 ::= ArgVar ; +I. Term2 ::= CIdent ; -- from resources +Par. Term2 ::= "<" CIdent [Term2] ">" ; +LI. Term2 ::= "$" Ident ; -- from pattern variables + +R. Term2 ::= "{" [Assign] "}" ; +P. Term1 ::= Term2 "." Label ; +T. Term1 ::= "table" CType "{" [Case] "}" ; +V. Term1 ::= "table" CType "[" [Term2] "]" ; +S. Term1 ::= Term1 "!" Term2 ; +C. Term ::= Term "++" Term1 ; +FV. Term1 ::= "variants" "{" [Term2] "}" ; --- no separator! + +EInt. Term2 ::= Integer ; +EFloat. Term2 ::= Double ; +K. Term2 ::= Tokn ; +E. Term2 ::= "[" "]" ; + +KS. Tokn ::= String ; +KP. Tokn ::= "[" "pre" [String] "{" [Variant] "}" "]" ; +internal KM. Tokn ::= String ; -- mark-up + +Ass. Assign ::= Label "=" Term ; +Cas. Case ::= [Patt] "=>" Term ; +Var. Variant ::= [String] "/" [String] ; + +coercions Term 2 ; + +L. Label ::= Ident ; +LV. Label ::= "$" Integer ; +A. ArgVar ::= Ident "@" Integer ; -- no bindings +AB. ArgVar ::= Ident "+" Integer "@" Integer ; -- with a number of bindings + +PC. Patt ::= "(" CIdent [Patt] ")" ; +PV. Patt ::= Ident ; +PW. Patt ::= "_" ; +PR. Patt ::= "{" [PattAssign] "}" ; +PI. Patt ::= Integer ; +PF. Patt ::= Double ; + +PAss. PattAssign ::= Label "=" Patt ; + +--- here we use the new pragmas to generate list rules + +terminator Flag ";" ; +terminator Def ";" ; +separator ParDef "|" ; +separator CType "" ; +separator CIdent "" ; +separator Assign ";" ; +separator ArgVar "," ; +separator Labelling ";" ; +separator Case ";" ; +separator Term2 "" ; +separator String "" ; +separator Variant ";" ; +separator PattAssign ";" ; +separator Patt "" ; +separator Ident "," ; + diff --git a/src-3.0/GF/Canon/GFC.hs b/src-3.0/GF/Canon/GFC.hs new file mode 100644 index 000000000..ae9097c44 --- /dev/null +++ b/src-3.0/GF/Canon/GFC.hs @@ -0,0 +1,103 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Canon/GetGFC.hs b/src-3.0/GF/Canon/GetGFC.hs new file mode 100644 index 000000000..049f75efe --- /dev/null +++ b/src-3.0/GF/Canon/GetGFC.hs @@ -0,0 +1,78 @@ +---------------------------------------------------------------------- +-- | +-- Module : GetGFC +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 18:39:43 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.9 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Canon.GetGFC (getCanonModule, getCanonGrammar) where + +import GF.Data.Operations +import GF.Canon.ParGFC +import GF.Canon.GFC +import GF.Canon.MkGFC +import GF.Infra.Modules +import GF.Infra.UseIO + +import System.IO +import System.Directory +import Control.Monad + +getCanonModule :: FilePath -> IOE CanonModule +getCanonModule file = do + gr <- getCanonGrammar file + case modules gr of + [m] -> return m + _ -> ioeErr $ Bad "expected exactly one module in a file" + +getCanonGrammar :: FilePath -> IOE CanonGrammar +-- getCanonGrammar = getCanonGrammarByLine +getCanonGrammar file = do + s <- ioeIO $ readFileIf file + c <- ioeErr $ pCanon $ myLexer s + return $ canon2grammar c + +{- +-- the following surprisingly does not save memory so it is +-- not in use + +getCanonGrammarByLine :: FilePath -> IOE CanonGrammar +getCanonGrammarByLine file = do + b <- ioeIO $ doesFileExist file + if not b + then ioeErr $ Bad $ "file" +++ file +++ "does not exist" + else do + ioeIO $ putStrLn "" + hand <- ioeIO $ openFile file ReadMode ---- err + size <- ioeIO $ hFileSize hand + gr <- addNextLine (size,0) 1 hand emptyMGrammar + ioeIO $ hClose hand + return $ MGrammar $ reverse $ modules gr + + where + addNextLine (size,act) d hand gr = do + eof <- ioeIO $ hIsEOF hand + if eof + then return gr + else do + s <- ioeIO $ hGetLine hand + let act' = act + toInteger (length s) +-- if isHash act act' then (ioeIO $ putChar '#') else return () + updGrammar act' d gr $ pLine $ myLexer s + where + updGrammar a d gr (Ok t) = case buildCanonGrammar d gr t of + (gr',d') -> addNextLine (size,a) d' hand gr' + updGrammar _ _ gr (Bad s) = do + ioeIO $ putStrLn s + return emptyMGrammar + + isHash a b = a `div` step < b `div` step + step = size `div` 50 +-} diff --git a/src-3.0/GF/Canon/LexGFC.hs b/src-3.0/GF/Canon/LexGFC.hs new file mode 100644 index 000000000..31a4a9b30 --- /dev/null +++ b/src-3.0/GF/Canon/LexGFC.hs @@ -0,0 +1,346 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 3 "LexGFC.x" #-} +module GF.Canon.LexGFC where --H + +import GF.Data.ErrM --H +import GF.Data.SharedString --H + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#else +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x1d\x00\x00\x00\x0b\x00\x00\x00\x20\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\x6d\x01\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\x07\x00\x05\x00\x03\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\x03\x00\x04\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x08\x00\x0a\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0b\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x2b\x00\x3e\x00\x2a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]] +{-# LINE 32 "LexGFC.x" #-} + +tok f p s = f p s + +share :: String -> String +share = shareString + +data Tok = + TS !String -- reserved words + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N))) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c + +alex_action_1 = tok (\p s -> PT p (TS $ share s)) +alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_3 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) +alex_action_4 = tok (\p s -> PT p (TI $ share s)) +alex_action_5 = tok (\p s -> PT p (TD $ share s)) +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + +{-# LINE 35 "GenericTemplate.hs" #-} + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + case s of + -1# -> (last_acc, input) + _ -> alex_scan_tkn' user orig_input len input s last_acc + +alex_scan_tkn' user orig_input len input s last_acc = + let + new_acc = check_accs (alex_accept `quickIndex` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/src-3.0/GF/Canon/LexGFC.x b/src-3.0/GF/Canon/LexGFC.x new file mode 100644 index 000000000..0a50e49d1 --- /dev/null +++ b/src-3.0/GF/Canon/LexGFC.x @@ -0,0 +1,132 @@ +-- -*- haskell -*- +-- This Alex file was machine-generated by the BNF converter +{ +module GF.Canon.LexGFC where + +import GF.Data.ErrM -- H +import GF.Data.SharedString -- H +} + + +$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME +$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME +$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME +$d = [0-9] -- digit +$i = [$l $d _ '] -- identifier character +$u = [\0-\255] -- universal: any character + +@rsyms = -- reserved words consisting of special symbols + \; | \= | \{ | \} | \: | \- \> | \* \* | \[ | \] | \\ | \. | \( | \) | \_ | \< | \> | \$ | \? | \= \> | \! | \+ \+ | \/ | \@ | \+ | \| | \, + +:- + +$white+ ; +@rsyms { tok (\p s -> PT p (TS $ share s)) } + +$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } +\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) } + +$d+ { tok (\p s -> PT p (TI $ share s)) } + + +{ + +tok f p s = f p s + +share :: String -> String +share = shareString + +data Tok = + TS !String -- reserved words + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N))) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c +} diff --git a/src-3.0/GF/Canon/Look.hs b/src-3.0/GF/Canon/Look.hs new file mode 100644 index 000000000..a93d4c834 --- /dev/null +++ b/src-3.0/GF/Canon/Look.hs @@ -0,0 +1,225 @@ +---------------------------------------------------------------------- +-- | +-- Module : Look +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/20 09:32:56 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.17 $ +-- +-- lookup in GFC. AR 2003 +----------------------------------------------------------------------------- + +module GF.Canon.Look (lookupCncInfo, + lookupLin, + lookupLincat, + lookupPrintname, + lookupResInfo, + lookupGlobal, + lookupOptionsCan, + lookupParamValues, + allParamValues, + ccompute + ) where + +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Grammar.PrGrammar +import GF.Canon.CMacros +----import Values +import GF.Grammar.MMacros +import GF.Grammar.Macros (zIdent) +import qualified GF.Infra.Modules as M +import qualified GF.Canon.CanonToGrammar as CG + +import GF.Data.Operations +import GF.Infra.Option + +import Control.Monad +import Data.List + +-- linearization lookup + +lookupCncInfo :: CanonGrammar -> CIdent -> Err Info +lookupCncInfo gr f@(CIQ m c) = do + mt <- M.lookupModule gr m + case mt of + M.ModMod a -> errIn ("module" +++ prt m) $ + lookupIdent c $ M.jments a + _ -> prtBad "not concrete module" m + +lookupLin :: CanonGrammar -> CIdent -> Err Term +lookupLin gr f = errIn "looking up linearization rule" $ do + info <- lookupCncInfo gr f + case info of + CncFun _ _ t _ -> return t + CncCat _ t _ -> return t + AnyInd _ n -> lookupLin gr $ redirectIdent n f + +lookupLincat :: CanonGrammar -> CIdent -> Err CType +lookupLincat gr (CIQ _ c) | elem c [zIdent "String", zIdent "Int", zIdent "Float"] = + return defLinType --- ad hoc; not needed? cf. Grammar.Lookup.lookupLincat +lookupLincat gr f = errIn "looking up linearization type" $ do + info <- lookupCncInfo gr f + case info of + CncCat t _ _ -> return t + AnyInd _ n -> lookupLincat gr $ redirectIdent n f + _ -> prtBad "no lincat found for" f + +lookupPrintname :: CanonGrammar -> CIdent -> Err Term +lookupPrintname gr f = errIn "looking up printname" $ do + info <- lookupCncInfo gr f + case info of + CncFun _ _ _ t -> return t + CncCat _ _ t -> return t + AnyInd _ n -> lookupPrintname gr $ redirectIdent n f + +lookupResInfo :: CanonGrammar -> CIdent -> Err Info +lookupResInfo gr f@(CIQ m c) = do + mt <- M.lookupModule gr m + case mt of + M.ModMod a -> lookupIdent c $ M.jments a + _ -> prtBad "not resource module" m + +lookupGlobal :: CanonGrammar -> CIdent -> Err Term +lookupGlobal gr f = do + info <- lookupResInfo gr f + case info of + ResOper _ t -> return t + AnyInd _ n -> lookupGlobal gr $ redirectIdent n f + _ -> prtBad "cannot find global" f + +lookupOptionsCan :: CanonGrammar -> Err Options +lookupOptionsCan gr = do + let fs = M.allFlags gr + os <- mapM CG.redFlag fs + return $ options os + +lookupParamValues :: CanonGrammar -> CIdent -> Err [Term] +lookupParamValues gr pt@(CIQ m _) = do + info <- lookupResInfo gr pt + case info of + ResPar ps -> liftM concat $ mapM mkPar ps + AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt + _ -> prtBad "cannot find parameter type" pt + where + mkPar (ParD f co) = do + vs <- liftM combinations $ mapM (allParamValues gr) co + return $ map (Par (CIQ m f)) vs + +-- this is needed since param type can also be a record type + +allParamValues :: CanonGrammar -> CType -> Err [Term] +allParamValues cnc ptyp = case ptyp of + Cn pc -> lookupParamValues cnc pc + RecType r -> do + let (ls,tys) = unzip [(l,t) | Lbg l t <- r] + tss <- mapM allPV tys + return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss] + TInts n -> return [EInt i | i <- [0..n]] + _ -> prtBad "cannot possibly find parameter values for" ptyp + where + allPV = allParamValues cnc + +-- runtime computation on GFC objects + +ccompute :: CanonGrammar -> [Term] -> Term -> Err Term +ccompute cnc = vcomp + where + + vcomp xs t = do + let xss = variations xs + ts <- mapM (\xx -> comp [] xx t) xss + return $ variants ts + + variations xs = combinations [getVariants t | t <- xs] + variants ts = case ts of + [t] -> t + _ -> FV ts + getVariants t = case t of + FV ts -> ts + _ -> [t] + + comp g xs t = case t of + Arg (A _ i) -> err (const (return t)) return $ xs !? fromInteger i + Arg (AB _ _ i) -> err (const (return t)) return $ xs !? fromInteger i + I c -> look c + LI c -> lookVar c g + + -- short-cut computation of selections: compute the table only if needed + S u v -> do + u' <- compt u + case u' of + T _ [Cas [PW] b] -> compt b + T _ [Cas [PV x] b] -> do + v' <- compt v + comp ((x,v') : g) xs b + T _ cs -> do + v' <- compt v + if noVar v' + then matchPatt cs v' >>= compt + else return $ S u' v' + FV ccs -> do + v' <- compt v + mapM (\c -> compt (S c v')) ccs >>= return . FV + + _ -> liftM (S u') $ compt v + + P u l -> do + u' <- compt u + case u' of + R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u')) + return $ + lookup l [ (x,y) | Ass x y <- rs] + FV rrs -> do + mapM (\r -> compt (P r l)) rrs >>= return . FV + + _ -> return $ P u' l + FV ts -> liftM FV (mapM compt ts) + C E b -> compt b + C a E -> compt a + C a b -> do + a' <- compt a + b' <- compt b + return $ case (a',b') of + (E,_) -> b' + (_,E) -> a' + _ -> C a' b' + R rs -> liftM (R . map (uncurry Ass)) $ + mapPairsM compt [(l,r) | Ass l r <- rs] + + -- only expand the table when the table is really needed: use expandLin + T ty rs -> liftM (T ty . map (uncurry Cas)) $ + mapPairsM compt [(l,r) | Cas l r <- rs] + + V ptyp ts -> do + ts' <- mapM compt ts + vs0 <- allParamValues cnc ptyp + vs <- mapM term2patt vs0 + let cc = [Cas [p] u | (p,u) <- zip vs ts'] + return $ T ptyp cc + + Par c xs -> liftM (Par c) $ mapM compt xs + + K (KS []) -> return E --- should not be needed + + _ -> return t + where + compt = comp g xs + look c = lookupGlobal cnc c >>= compt + + lookVar c co = case lookup c co of + Just t -> return t + _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- + + noVar v = case v of + LI _ -> False + Arg _ -> False + R rs -> all noVar [t | Ass _ t <- rs] + Par _ ts -> all noVar ts + FV ts -> all noVar ts + S x y -> noVar x && noVar y + P t _ -> noVar t + _ -> True --- other cases that can be values to pattern match? diff --git a/src-3.0/GF/Canon/MkGFC.hs b/src-3.0/GF/Canon/MkGFC.hs new file mode 100644 index 000000000..8443354fc --- /dev/null +++ b/src-3.0/GF/Canon/MkGFC.hs @@ -0,0 +1,237 @@ +---------------------------------------------------------------------- +-- | +-- Module : MkGFC +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/04 11:45:38 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.16 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr, + canon2grammar, grammar2canon, -- buildCanonGrammar, + info2mod,info2def, + trExp, rtExp, rtQIdent) where + +import GF.Canon.GFC +import GF.Canon.AbsGFC +import qualified GF.Grammar.Abstract as A +import GF.Grammar.PrGrammar + +import GF.Infra.Ident +import GF.Data.Operations +import qualified GF.Infra.Modules as M + +prCanonModInfo :: CanonModule -> String +prCanonModInfo = prt . info2mod + +prCanon :: CanonGrammar -> String +prCanon = unlines . map prCanonModInfo . M.modules + +prCanonMGr :: CanonGrammar -> String +prCanonMGr g = header ++++ prCanon g where + header = case M.greatestAbstract g of + Just a -> prt (MGr (M.allConcretes g a) a []) + _ -> [] + +canon2grammar :: Canon -> CanonGrammar +canon2grammar (MGr _ _ modules) = canon2grammar (Gr modules) ---- ignoring the header +canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules + +mod2info m = case m of + Mod mt e os flags defs -> + let defs' = buildTree $ map def2info defs + (a,mt') = case mt of + MTAbs a -> (a,M.MTAbstract) + MTRes a -> (a,M.MTResource) + MTCnc a x -> (a,M.MTConcrete x) + MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y)) + in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs')) + where + ee (Ext m) = map M.inheritAll m + ee _ = [] + oo (Opens ms) = map M.oSimple ms + oo _ = [] + +grammar2canon :: CanonGrammar -> Canon +grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules + +info2mod :: (Ident, M.ModInfo Ident Flag Info) -> Module +info2mod m = case m of + (a, M.ModMod (M.Module mt _ flags me os defs)) -> + let defs' = map info2def $ tree2list defs + mt' = case mt of + M.MTAbstract -> MTAbs a + M.MTResource -> MTRes a + M.MTConcrete x -> MTCnc a x + M.MTTransfer (M.OSimple _ x) (M.OSimple _ y) -> MTTrans a x y + in + Mod mt' (gfcE me) (gfcO os) flags defs' + where + gfcE = ifNull NoExt Ext . map fst + gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os] + + +-- these translations are meant to be trivial + +defs2infos = sorted2tree . map def2info + +def2info d = case d of + AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs)) + AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df)) + AbsDTrans c t -> (c,AbsTrans (trExp t)) + ResDPar c df -> (c,ResPar df) + ResDOper c ty df -> (c,ResOper ty df) + CncDCat c ty df pr -> (c, CncCat ty df pr) + CncDFun f c xs li pr -> (f, CncFun c xs li pr) + AnyDInd c b m -> (c, AnyInd (b == Canon) m) + +-- from file to internal + +trCont cont = [(x,trExp t) | Decl x t <- cont] + +trFs = map trQIdent + +trExp :: Exp -> A.Term +trExp t = case t of + EProd x a b -> A.Prod x (trExp a) (trExp b) + EAbs x b -> A.Abs x (trExp b) + EApp f a -> A.App (trExp f) (trExp a) + EEq eqs -> A.Eqs [(map trPt ps, trExp e) | Equ ps e <- eqs] + EData -> A.EData + _ -> trAt t + where + trAt (EAtom t) = case t of + AC c -> (uncurry A.Q) $ trQIdent c + AD c -> (uncurry A.QC) $ trQIdent c + AV v -> A.Vr v + AM i -> A.Meta $ A.MetaSymb $ fromInteger i + AT s -> A.Sort $ prt s + AS s -> A.K s + AI i -> A.EInt $ i + AF i -> A.EFloat $ i + trPt p = case p of + APC mc ps -> let (m,c) = trQIdent mc in A.PP m c (map trPt ps) + APV x -> A.PV x + APS s -> A.PString s + API i -> A.PInt $ i + APF i -> A.PFloat $ i + APW -> A.PW + +trQIdent (CIQ m c) = (m,c) + +-- from internal to file + +infos2defs = map info2def . tree2list + +info2def d = case d of + (c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs) + (c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df) + (c,AbsTrans t) -> AbsDTrans c (rtExp t) + (c,ResPar df) -> ResDPar c df + (c,ResOper ty df) -> ResDOper c ty df + (c,CncCat ty df pr) -> CncDCat c ty df pr + (f,CncFun c xs li pr) -> CncDFun f c xs li pr + (c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m + +rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont] + +rtFs = map rtQIdent + +rtExp :: A.Term -> Exp +rtExp t = case t of + A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b) + A.Abs x b -> EAbs (rtIdent x) (rtExp b) + A.App f a -> EApp (rtExp f) (rtExp a) + A.Eqs eqs -> EEq [Equ (map rtPt ps) (rtExp e) | (ps,e) <- eqs] + A.EData -> EData + _ -> EAtom $ rtAt t + where + rtAt t = case t of + A.Q m c -> AC $ rtQIdent (m,c) + A.QC m c -> AD $ rtQIdent (m,c) + A.Vr v -> AV v + A.Meta i -> AM $ toInteger $ A.metaSymbInt i + A.Sort "Type" -> AT SType + A.K s -> AS s + A.EInt i -> AI $ toInteger i + _ -> error $ "MkGFC.rt not defined for" +++ show t + rtPt p = case p of + A.PP m c ps -> APC (rtQIdent (m,c)) (map rtPt ps) + A.PV x -> APV x + A.PString s -> APS s + A.PInt i -> API $ toInteger i + A.PW -> APW + _ -> error $ "MkGFC.rt not defined for" +++ show p + + +rtQIdent :: (Ident, Ident) -> CIdent +rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c) +rtIdent x + | isWildIdent x = identC "h_" --- needed in declarations + | otherwise = identC $ prt x --- + +{- +-- the following is called in GetGFC to read gfc files line +-- by line. It does not save memory, though, and is therefore +-- not used. + +buildCanonGrammar :: Int -> CanonGrammar -> Line -> (CanonGrammar,Int) +buildCanonGrammar n gr0 line = mgr $ case line of +-- LMulti ids id + LHeader mt ext op -> newModule mt ext op + LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n + LFlag flag -> newFlag flag + LDef def -> newDef $ def2info def +-- LEnd -> cleanNames + _ -> M.modules gr0 + where + newModule mt ext op = mod2info (Mod mt ext op [] []) : mods + initModule f i = case actm of + (name, M.ModMod (M.Module mt com flags ee oo defs)) -> + (name, M.ModMod (M.Module mt com (f:flags) ee oo (newtree i))) : tmods + newFlag f = case actm of + (name, M.ModMod (M.Module mt com flags ee oo defs)) -> + (name, M.ModMod (M.Module mt com (f:flags) ee oo defs)) : tmods + newDef d = case actm of + (name, M.ModMod (M.Module mt com flags ee oo defs)) -> + (name, M.ModMod (M.Module mt com flags ee oo + (upd (padd 8 n) d defs))) : tmods + +-- cleanNames = case actm of +-- (name, M.ModMod (M.Module mt com flags ee oo defs)) -> +-- (name, M.ModMod (M.Module mt com (reverse flags) ee oo +-- (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods + + actm = head mods -- only used when a new mod has been created + mods = M.modules gr0 + tmods = tail mods + + mgr ms = (M.MGrammar ms, case line of + LDef _ -> n+1 + LEnd -> 1 + _ -> n + ) + + -- create an initial tree with who-cares value + newtree (i :: Int) = emptyBinTree +-- newtree (i :: Int) = sorted2tree [ +-- (padd 8 k, ResPar []) | +-- k <- [1..i]] --- padd (length (show i)) + + padd l k = 0 +-- padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk) + + upd _ d defs = updateTree d defs +-- upd n d@(f,t) defs = case defs of +-- NT -> BT (merg n f,t) NT NT --- should not happen +-- BT c@(a,_) left right +-- | n < a -> let left' = upd n d left in BT c left' right +-- | n > a -> let right' = upd n d right in BT c left right' +-- | otherwise -> BT (merg n f,t) left right +-- merg (IC n) (IC f) = IC (n ++ f) +-} diff --git a/src-3.0/GF/Canon/ParGFC.hs b/src-3.0/GF/Canon/ParGFC.hs new file mode 100644 index 000000000..4332c06e4 --- /dev/null +++ b/src-3.0/GF/Canon/ParGFC.hs @@ -0,0 +1,2142 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +module GF.Canon.ParGFC where -- H +import GF.Canon.AbsGFC -- H +import GF.Canon.LexGFC -- H +import GF.Data.ErrM -- H +import GF.Infra.Ident -- H +import Array +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.15 + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn5 :: (Ident) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Ident) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (String) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (String) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (Integer) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Integer) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Double) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (Double) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Canon) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Canon) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Line) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Line) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Module) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Module) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (ModType) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (ModType) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([Module]) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([Module]) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (Extend) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (Extend) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Open) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Open) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (Flag) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (Flag) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (Def) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (Def) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (ParDef) -> (HappyAbsSyn ) +happyIn18 x = unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (ParDef) +happyOut18 x = unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: (Status) -> (HappyAbsSyn ) +happyIn19 x = unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> (Status) +happyOut19 x = unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (CIdent) -> (HappyAbsSyn ) +happyIn20 x = unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (CIdent) +happyOut20 x = unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (Exp) -> (HappyAbsSyn ) +happyIn21 x = unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> (Exp) +happyOut21 x = unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (Exp) -> (HappyAbsSyn ) +happyIn22 x = unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (Exp) +happyOut22 x = unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: (Exp) -> (HappyAbsSyn ) +happyIn23 x = unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> (Exp) +happyOut23 x = unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: (Sort) -> (HappyAbsSyn ) +happyIn24 x = unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> (Sort) +happyOut24 x = unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: (Equation) -> (HappyAbsSyn ) +happyIn25 x = unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> (Equation) +happyOut25 x = unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: (APatt) -> (HappyAbsSyn ) +happyIn26 x = unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> (APatt) +happyOut26 x = unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: ([Decl]) -> (HappyAbsSyn ) +happyIn27 x = unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> ([Decl]) +happyOut27 x = unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: ([APatt]) -> (HappyAbsSyn ) +happyIn28 x = unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> ([APatt]) +happyOut28 x = unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: ([Equation]) -> (HappyAbsSyn ) +happyIn29 x = unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> ([Equation]) +happyOut29 x = unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: (Atom) -> (HappyAbsSyn ) +happyIn30 x = unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> (Atom) +happyOut30 x = unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: (Decl) -> (HappyAbsSyn ) +happyIn31 x = unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> (Decl) +happyOut31 x = unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: (CType) -> (HappyAbsSyn ) +happyIn32 x = unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> (CType) +happyOut32 x = unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: (Labelling) -> (HappyAbsSyn ) +happyIn33 x = unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> (Labelling) +happyOut33 x = unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: (Term) -> (HappyAbsSyn ) +happyIn34 x = unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> (Term) +happyOut34 x = unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: (Term) -> (HappyAbsSyn ) +happyIn35 x = unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> (Term) +happyOut35 x = unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: (Term) -> (HappyAbsSyn ) +happyIn36 x = unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> (Term) +happyOut36 x = unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (Tokn) -> (HappyAbsSyn ) +happyIn37 x = unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> (Tokn) +happyOut37 x = unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: (Assign) -> (HappyAbsSyn ) +happyIn38 x = unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> (Assign) +happyOut38 x = unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: (Case) -> (HappyAbsSyn ) +happyIn39 x = unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> (Case) +happyOut39 x = unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: (Variant) -> (HappyAbsSyn ) +happyIn40 x = unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> (Variant) +happyOut40 x = unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: (Label) -> (HappyAbsSyn ) +happyIn41 x = unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> (Label) +happyOut41 x = unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: (ArgVar) -> (HappyAbsSyn ) +happyIn42 x = unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> (ArgVar) +happyOut42 x = unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: (Patt) -> (HappyAbsSyn ) +happyIn43 x = unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> (Patt) +happyOut43 x = unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: (PattAssign) -> (HappyAbsSyn ) +happyIn44 x = unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> (PattAssign) +happyOut44 x = unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: ([Flag]) -> (HappyAbsSyn ) +happyIn45 x = unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> ([Flag]) +happyOut45 x = unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: ([Def]) -> (HappyAbsSyn ) +happyIn46 x = unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> ([Def]) +happyOut46 x = unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: ([ParDef]) -> (HappyAbsSyn ) +happyIn47 x = unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> ([ParDef]) +happyOut47 x = unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: ([CType]) -> (HappyAbsSyn ) +happyIn48 x = unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> ([CType]) +happyOut48 x = unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: ([CIdent]) -> (HappyAbsSyn ) +happyIn49 x = unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> ([CIdent]) +happyOut49 x = unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: ([Assign]) -> (HappyAbsSyn ) +happyIn50 x = unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> ([Assign]) +happyOut50 x = unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: ([ArgVar]) -> (HappyAbsSyn ) +happyIn51 x = unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> ([ArgVar]) +happyOut51 x = unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: ([Labelling]) -> (HappyAbsSyn ) +happyIn52 x = unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> ([Labelling]) +happyOut52 x = unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: ([Case]) -> (HappyAbsSyn ) +happyIn53 x = unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> ([Case]) +happyOut53 x = unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: ([Term]) -> (HappyAbsSyn ) +happyIn54 x = unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> ([Term]) +happyOut54 x = unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyIn55 :: ([String]) -> (HappyAbsSyn ) +happyIn55 x = unsafeCoerce# x +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> ([String]) +happyOut55 x = unsafeCoerce# x +{-# INLINE happyOut55 #-} +happyIn56 :: ([Variant]) -> (HappyAbsSyn ) +happyIn56 x = unsafeCoerce# x +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> ([Variant]) +happyOut56 x = unsafeCoerce# x +{-# INLINE happyOut56 #-} +happyIn57 :: ([PattAssign]) -> (HappyAbsSyn ) +happyIn57 x = unsafeCoerce# x +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> ([PattAssign]) +happyOut57 x = unsafeCoerce# x +{-# INLINE happyOut57 #-} +happyIn58 :: ([Patt]) -> (HappyAbsSyn ) +happyIn58 x = unsafeCoerce# x +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> ([Patt]) +happyOut58 x = unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyIn59 :: ([Ident]) -> (HappyAbsSyn ) +happyIn59 x = unsafeCoerce# x +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> ([Ident]) +happyOut59 x = unsafeCoerce# x +{-# INLINE happyOut59 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x74\x02\xa7\x00\x6e\x02\x00\x00\x6c\x02\x66\x02\x89\x02\x88\x02\x84\x02\x00\x00\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x62\x02\x52\x02\x21\x02\x60\x02\x6d\x02\x5e\x02\x00\x00\x82\x02\x5b\x02\xdb\x00\x00\x00\x80\x02\x7e\x02\x7d\x02\x79\x02\x59\x02\x78\x02\x7a\x02\x58\x02\x73\x02\x00\x00\x00\x00\x00\x00\x28\x00\x53\x02\x00\x00\x46\x02\x51\x02\x72\x02\x44\x02\x44\x02\x44\x02\x8b\x00\x44\x02\x44\x02\x9b\x00\x9b\x00\x44\x02\x8b\x00\x44\x02\x71\x02\x28\x00\x42\x02\x42\x02\x00\x00\x70\x02\x4b\x02\x6a\x02\x64\x02\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x02\x8b\x00\x38\x02\x38\x02\x3f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x00\x00\x6b\x02\xf7\xff\x9b\x00\x39\x02\x00\x00\x69\x02\x68\x02\x67\x02\x65\x02\x00\x00\x00\x00\x61\x02\x5c\x02\x63\x02\x00\x00\x5f\x02\x30\x02\x00\x00\x3e\x02\x00\x00\x2f\x02\x5d\x02\x8b\x00\x8b\x00\x00\x00\x54\x02\x12\x00\x00\x00\x4a\x02\x00\x00\x5a\x02\x57\x02\x56\x02\x26\x02\x12\x00\x27\x02\x9b\x00\x00\x00\x00\x00\x47\x02\xd7\x00\x48\x02\x50\x02\x4d\x02\x00\x00\x8b\x00\x23\x02\x23\x02\x4f\x02\x00\x00\x21\x02\x00\x00\x00\x00\x00\x00\x4e\x02\x7e\x00\x00\x00\x8b\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x02\x36\x02\x33\x02\x00\x00\x00\x00\xf7\xff\xfe\xff\x12\x00\x16\x02\x16\x02\x9b\x00\x43\x02\x00\x00\x00\x00\x00\x00\x9b\x00\xf7\xff\x9b\x00\xba\x00\x14\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x02\x66\x00\x2a\x02\x3d\x02\x12\x00\x12\x00\x35\x02\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x07\x00\x00\x00\x00\x00\x3c\x02\x2c\x02\x29\x02\x5f\x00\xf7\xff\x0d\x02\x0d\x02\x1e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\xfb\x01\x00\x00\x00\x00\x08\x02\x28\x02\xb4\x00\x00\x00\x00\x00\x22\x02\x0c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\xf7\xff\x1a\x00\x00\x00\x55\x00\x10\x02\x00\x00\x4f\x00\x00\x00\xff\x01\xfc\x01\x12\x00\xe1\x01\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x1d\x00\x0f\x02\x0a\x02\x65\x00\x00\x00\x00\x00\x6f\x00\x00\x00\xfa\x01\xd6\x01\x8b\x00\xda\x00\xf9\x01\x00\x00\xc8\x01\x00\x00\xf6\x01\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x01\x59\x00\xf3\x01\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\xc5\x01\x00\x00\x12\x00\x00\x00\xf0\x01\x00\x00\x12\x00\xc9\x01\x00\x00\xc9\x01\x00\x00\xdd\x01\xdc\x01\xd8\x01\xd1\x01\x00\x00\x37\x00\x00\x00\xa9\x01\x00\x00\x00\x00\xf7\xff\x16\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x9c\x00\x5d\x01\x00\x00\x00\x00\xb7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\xc2\x01\xc1\x01\xbc\x01\xb1\x01\x06\x00\xb0\x01\xa8\x01\xa4\x01\x8f\x01\x8e\x01\x8c\x01\x00\x00\x6e\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x86\x01\x72\x01\x00\x00\x9f\x00\x7b\x01\x70\x01\x25\x02\x65\x01\xe0\x01\x36\x01\x19\x01\xa6\x00\x20\x02\x52\x01\x00\x00\x01\x00\x40\x01\x04\x00\x00\x00\x00\x00\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x3c\x01\x0b\x02\xc6\x01\x3b\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x18\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x06\x02\xf1\x01\x00\x00\x00\x00\x7e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x01\x6b\x01\x6a\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xec\x01\x1f\x01\x1d\x01\x00\x00\x14\x01\x6e\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xab\x01\x00\x00\xd7\x01\x00\x00\xd2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x58\x01\xb4\x01\xfd\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x0f\x00\x0c\x00\x00\x00\x35\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\xa6\x01\x00\x00\x00\x00\x00\x00\x54\x01\x82\x01\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x96\x01\x0e\x00\xe8\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x01\x37\x01\x00\x00\x00\x00\x51\x00\x00\x00\x03\x01\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\xc0\x00\xa1\x00\x00\x00\x92\x01\x3a\x01\x5c\x00\x92\x01\x00\x00\x00\x00\x00\x00\x2e\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x01\x00\x00\x00\x00\xff\x00\x00\x00\x00\x00\x77\x01\x00\x00\x00\x00\x74\x00\xb8\x01\xab\x01\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x10\x00\x00\x00\x2a\x01\x00\x00\x3d\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\x91\x00\x00\x00\x17\x00\x00\x00\x00\x00\x09\x00\xf8\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xed\xff\x00\x00\x00\x00\xfd\xff\xdc\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x6f\xff\x6e\xff\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xff\xf4\xff\xf5\xff\xea\xff\x00\x00\xdd\xff\x00\x00\xe8\xff\x00\x00\xc9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xff\x00\x00\x00\x00\x00\x00\xea\xff\x00\x00\x6f\xff\x6d\xff\x00\x00\xe8\xff\x00\x00\x00\x00\xbe\xff\xbd\xff\xc2\xff\xd5\xff\xe4\xff\xd9\xff\xbc\xff\xd4\xff\xc4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\xff\xd3\xff\xfc\xff\xfb\xff\x8b\xff\x8d\xff\xe3\xff\xb8\xff\x00\x00\x81\xff\x00\x00\x00\x00\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\xf0\xff\x00\x00\x00\x00\xc8\xff\xeb\xff\x00\x00\x6f\xff\xdf\xff\x00\x00\xf6\xff\xc9\xff\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\x00\x00\xb6\xff\x00\x00\x9d\xff\x80\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xff\xde\xff\xbf\xff\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xff\xda\xff\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xf9\xff\x92\xff\xee\xff\xdb\xff\x00\x00\x00\x00\xd6\xff\x00\x00\xd2\xff\x00\x00\xc1\xff\x8a\xff\x8c\xff\x00\x00\xa2\xff\xaf\xff\xae\xff\xb3\xff\xa5\xff\xa3\xff\xe2\xff\xad\xff\xb4\xff\x87\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x9c\xff\xba\xff\x00\x00\x81\xff\x00\x00\x00\x00\x84\xff\xe5\xff\xbb\xff\x89\xff\xc7\xff\xe9\xff\xe6\xff\x00\x00\x83\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xff\xb5\xff\x7b\xff\x00\x00\xb1\xff\x7b\xff\x00\x00\xac\xff\x79\xff\x86\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xff\xce\xff\xcd\xff\xcc\xff\xcb\xff\xc5\xff\x00\x00\x00\x00\xca\xff\xc3\xff\x90\xff\x00\x00\x00\x00\xc6\xff\xd0\xff\x00\x00\x00\x00\x9b\xff\xaa\xff\xa7\xff\xb0\xff\x00\x00\x87\xff\x00\x00\xab\xff\x00\x00\x71\xff\x7b\xff\x00\x00\xb9\xff\xa4\xff\xe1\xff\x00\x00\x84\xff\x88\xff\x82\xff\x00\x00\x7a\xff\xa6\xff\x00\x00\x7d\xff\x00\x00\x00\x00\xb2\xff\x78\xff\x77\xff\x85\xff\xa0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\x00\x00\x91\xff\x00\x00\x8f\xff\xcf\xff\xd8\xff\x9a\xff\x76\xff\x00\x00\x00\x00\x98\xff\x95\xff\x94\xff\x70\xff\x74\xff\x00\x00\x97\xff\x00\x00\xa9\xff\x71\xff\xa8\xff\x00\x00\xe0\xff\x7c\xff\x9f\xff\x71\xff\x00\x00\x73\xff\x00\x00\x00\x00\x79\xff\x77\xff\x75\xff\x9e\xff\xa1\xff\x96\xff\x74\xff\x00\x00\x00\x00\x99\xff\x93\xff\x72\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x11\x00\x00\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x14\x00\x0d\x00\x03\x00\x17\x00\x35\x00\x01\x00\x03\x00\x08\x00\x0f\x00\x15\x00\x03\x00\x0c\x00\x0f\x00\x03\x00\x0f\x00\x0c\x00\x11\x00\x0e\x00\x08\x00\x09\x00\x1b\x00\x31\x00\x0c\x00\x2c\x00\x1c\x00\x0f\x00\x24\x00\x11\x00\x07\x00\x27\x00\x24\x00\x24\x00\x24\x00\x27\x00\x00\x00\x25\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x34\x00\x2f\x00\x2e\x00\x2e\x00\x34\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x31\x00\x01\x00\x33\x00\x34\x00\x03\x00\x32\x00\x16\x00\x31\x00\x32\x00\x33\x00\x34\x00\x03\x00\x04\x00\x0c\x00\x0d\x00\x0e\x00\x08\x00\x03\x00\x31\x00\x25\x00\x0c\x00\x0b\x00\x08\x00\x0f\x00\x22\x00\x11\x00\x0c\x00\x03\x00\x2e\x00\x0f\x00\x10\x00\x11\x00\x08\x00\x03\x00\x32\x00\x00\x00\x0c\x00\x00\x00\x30\x00\x0f\x00\x16\x00\x11\x00\x0c\x00\x35\x00\x0e\x00\x06\x00\x07\x00\x02\x00\x0d\x00\x13\x00\x31\x00\x29\x00\x33\x00\x34\x00\x17\x00\x18\x00\x00\x00\x31\x00\x32\x00\x33\x00\x34\x00\x06\x00\x16\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x00\x32\x00\x0e\x00\x31\x00\x03\x00\x00\x00\x31\x00\x32\x00\x33\x00\x34\x00\x2a\x00\x0a\x00\x31\x00\x0c\x00\x33\x00\x34\x00\x0f\x00\x1c\x00\x11\x00\x12\x00\x03\x00\x00\x00\x04\x00\x32\x00\x01\x00\x24\x00\x08\x00\x16\x00\x00\x00\x0c\x00\x1d\x00\x1a\x00\x17\x00\x04\x00\x21\x00\x01\x00\x2f\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0d\x00\x23\x00\x16\x00\x1b\x00\x1c\x00\x04\x00\x1a\x00\x03\x00\x01\x00\x31\x00\x32\x00\x33\x00\x08\x00\x00\x00\x15\x00\x32\x00\x32\x00\x33\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x23\x00\x24\x00\x31\x00\x26\x00\x27\x00\x15\x00\x2a\x00\x2a\x00\x2b\x00\x1f\x00\x2d\x00\x02\x00\x2f\x00\x23\x00\x31\x00\x31\x00\x26\x00\x27\x00\x05\x00\x02\x00\x2a\x00\x2b\x00\x05\x00\x21\x00\x0b\x00\x2f\x00\x24\x00\x31\x00\x0c\x00\x0d\x00\x0e\x00\x21\x00\x02\x00\x0c\x00\x24\x00\x2d\x00\x0f\x00\x00\x00\x11\x00\x12\x00\x31\x00\x2c\x00\x00\x00\x2d\x00\x02\x00\x03\x00\x00\x00\x00\x00\x02\x00\x03\x00\x1d\x00\x00\x00\x0f\x00\x00\x00\x21\x00\x02\x00\x03\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x0b\x00\x1b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x00\x31\x00\x32\x00\x33\x00\x0f\x00\x1b\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x26\x00\x28\x00\x08\x00\x00\x00\x26\x00\x00\x00\x02\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x26\x00\x0f\x00\x0f\x00\x0f\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1b\x00\x1b\x00\x1b\x00\x02\x00\x00\x00\x00\x00\x2b\x00\x0f\x00\x02\x00\x00\x00\x00\x00\x0f\x00\x18\x00\x0a\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x0f\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x25\x00\x0f\x00\x1b\x00\x00\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x22\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x05\x00\x0f\x00\x07\x00\x00\x00\x25\x00\x0f\x00\x0b\x00\x0c\x00\x30\x00\x00\x00\x01\x00\x02\x00\x03\x00\x35\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x25\x00\x0f\x00\x00\x00\x0a\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x25\x00\x0f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x1d\x00\x1e\x00\x0f\x00\x20\x00\x25\x00\x00\x00\x0f\x00\x00\x00\x25\x00\x00\x00\x32\x00\x33\x00\x00\x00\x01\x00\x02\x00\x03\x00\x1d\x00\x00\x00\x00\x00\x20\x00\x1d\x00\x00\x00\x0f\x00\x20\x00\x25\x00\x00\x00\x01\x00\x02\x00\x25\x00\x00\x00\x00\x00\x01\x00\x02\x00\x15\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x0f\x00\x19\x00\x00\x00\x01\x00\x02\x00\x09\x00\x32\x00\x04\x00\x01\x00\x15\x00\x02\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x0f\x00\x19\x00\x00\x00\x01\x00\x02\x00\x04\x00\x01\x00\x31\x00\x04\x00\x02\x00\x31\x00\x01\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x33\x00\x19\x00\x00\x00\x01\x00\x02\x00\x04\x00\x15\x00\x01\x00\x15\x00\x31\x00\x14\x00\x04\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x17\x00\x19\x00\x00\x00\x01\x00\x02\x00\x06\x00\x01\x00\x22\x00\x0d\x00\x31\x00\x04\x00\x02\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x19\x00\x00\x00\x01\x00\x02\x00\x01\x00\x19\x00\x1e\x00\x33\x00\x20\x00\x0d\x00\x06\x00\x1a\x00\x31\x00\x03\x00\x31\x00\x15\x00\x0f\x00\x14\x00\x0b\x00\x12\x00\x13\x00\x2d\x00\x01\x00\x2f\x00\x04\x00\x03\x00\x19\x00\x31\x00\x0d\x00\x06\x00\x10\x00\x31\x00\x33\x00\x04\x00\x01\x00\x05\x00\x13\x00\x0a\x00\x02\x00\x31\x00\x31\x00\x03\x00\x25\x00\x01\x00\x09\x00\x05\x00\x02\x00\x01\x00\x31\x00\x02\x00\x02\x00\x33\x00\x02\x00\x19\x00\x0b\x00\x06\x00\x01\x00\x33\x00\x31\x00\x29\x00\x31\x00\x05\x00\x31\x00\x25\x00\x07\x00\x29\x00\x08\x00\x02\x00\x05\x00\x05\x00\x02\x00\x28\x00\x28\x00\x02\x00\x05\x00\x02\x00\x01\x00\x28\x00\x1a\x00\x36\x00\x01\x00\xff\xff\x02\x00\x31\x00\x21\x00\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\xc8\x00\x7e\x00\x79\x00\x43\x00\x30\x00\x45\x00\x79\x00\x79\x00\x79\x00\x45\x00\xba\x00\x27\x01\x92\x00\xea\x00\xa6\x00\x93\x00\x2c\x01\xfd\x00\x15\x01\xa7\x00\x5b\x00\xbf\x00\xff\x00\xa8\x00\x1f\x01\xa6\x00\xa9\x00\x16\x01\xaa\x00\x17\x01\xa7\x00\x1b\x01\xbf\x00\x04\x00\xa8\x00\xc9\x00\x7a\x00\xa9\x00\x20\x01\xaa\x00\x6f\xff\x21\x01\x20\x01\xe3\x00\x7b\x00\x21\x01\xba\x00\xbb\x00\x31\x00\x31\x00\x6e\x00\x41\x00\x1a\x00\x24\x00\x2f\x01\xc0\x00\xf4\x00\xab\x00\x22\x01\xac\x00\x04\x00\x57\x00\x58\x00\xad\x00\x04\x00\xfd\x00\x58\x00\xad\x00\x15\x01\x57\x00\x79\xff\x04\x00\x57\x00\x58\x00\xad\x00\xa6\x00\xf8\x00\x16\x01\x2e\x01\x17\x01\xa7\x00\xa6\x00\x04\x00\xbb\x00\xa8\x00\xdc\x00\xa7\x00\xa9\x00\xf9\x00\xaa\x00\xa8\x00\xa6\x00\xbc\x00\xa9\x00\xfd\x00\xaa\x00\xa7\x00\x15\x01\x79\xff\x58\x00\xa8\x00\x08\x01\x1d\x01\xa9\x00\x25\x01\xaa\x00\x16\x01\xfb\x00\x17\x01\x1b\x00\x1c\x00\x0c\x01\x59\x00\x18\x01\x04\x00\xdd\x00\x58\x00\xad\x00\xcf\x00\xd0\x00\x79\x00\x04\x00\x57\x00\x58\x00\xad\x00\xd8\x00\x79\xff\x04\x00\x57\x00\x58\x00\xad\x00\xd9\x00\x57\x00\xda\x00\xf8\x00\x4f\x00\x67\x00\x04\x00\x57\x00\x58\x00\xad\x00\x9a\x00\x50\x00\x04\x00\x51\x00\x58\x00\xad\x00\x52\x00\x7a\x00\x53\x00\x54\x00\x5e\x00\x67\x00\x16\x00\x79\xff\xfd\x00\x7b\x00\x17\x00\xb7\x00\x58\x00\x5f\x00\x55\x00\x69\x00\x03\x01\x0a\x00\x56\x00\x1c\x01\x7c\x00\x04\x00\x57\x00\x58\x00\xad\x00\x59\x00\x0d\x01\x68\x00\x60\x00\x61\x00\x06\x01\x69\x00\xec\x00\xbe\x00\x04\x00\x57\x00\x58\x00\xed\x00\x79\x00\xbf\x00\xe8\x00\x0e\x01\x26\x01\x0b\x00\x0c\x00\x0d\x00\x79\x00\x0e\x00\x0f\x00\x10\x00\x04\x00\x11\x00\x12\x00\xbf\x00\x5a\x00\x13\x00\x14\x00\x0c\x00\x15\x00\xe1\x00\x16\x00\x0f\x00\x04\x00\xea\x00\x11\x00\x12\x00\x98\x00\x3c\x00\x13\x00\x14\x00\x3d\x00\xc9\x00\x8b\x00\x07\x01\xca\x00\x04\x00\xd9\x00\x0b\x01\xda\x00\xc9\x00\xe2\x00\x8a\x00\xca\x00\xff\x00\x52\x00\x45\x00\x53\x00\x54\x00\xed\x00\xb9\x00\x10\x01\xcb\x00\x11\x01\x12\x01\x10\x01\x45\x00\x11\x01\x12\x01\x55\x00\xc4\x00\x5b\x00\x10\x01\x56\x00\x11\x01\x12\x01\x04\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x5b\x00\x8b\x00\xc1\x00\x04\x00\x57\x00\x58\x00\xad\x00\x04\x01\x04\x00\x57\x00\x58\x00\x9f\x00\xc3\x00\xcf\x00\xd0\x00\x45\x00\x45\x00\x45\x00\x13\x01\xdb\x00\x8e\x00\x90\x00\x2e\x01\x91\x00\xad\x00\xa0\x00\xa1\x00\x1c\x01\xa3\x00\x13\x01\x5b\x00\x5b\x00\x5b\x00\xa4\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x99\x00\x78\x00\x5c\x00\x77\x00\x45\x00\x45\x00\x80\x00\x9f\x00\x81\x00\x82\x00\x86\x00\x9f\x00\x87\x00\x8c\x00\x42\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x5b\x00\xde\x00\xa0\x00\xa1\x00\x1e\x01\xa3\x00\xa0\x00\xa1\x00\xf5\x00\xa3\x00\xa4\x00\x9f\x00\x61\x00\x44\x00\xa4\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\xf9\x00\x04\x00\xa0\x00\xa1\x00\x00\x01\xa3\x00\x05\x00\x9f\x00\x06\x00\x63\x00\xa4\x00\x9f\x00\x07\x00\x08\x00\xfa\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\xfb\x00\x65\x00\xa0\x00\xa1\x00\xf0\x00\xa3\x00\xa0\x00\xa1\x00\xc6\x00\xa3\x00\xa4\x00\x9f\x00\x66\x00\x6b\x00\xa4\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x6d\x00\x3d\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x1e\x00\x9f\x00\x1f\x00\x20\x00\xa4\x00\x9f\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x0d\x01\xa0\x00\xa1\x00\xb2\x00\xa3\x00\xa0\x00\xef\x00\x9f\x00\xa3\x00\xa4\x00\x21\x00\x9f\x00\x45\x00\xa4\x00\x22\x00\x0e\x01\x0f\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xf6\x00\x23\x00\x25\x00\xa3\x00\xe4\x00\x45\x00\xf3\x00\xa3\x00\xa4\x00\x45\x00\x46\x00\x47\x00\xa4\x00\x26\x00\x45\x00\x46\x00\x47\x00\xd6\x00\x27\x00\x28\x00\xc5\x00\x29\x00\x2d\x00\x45\x00\x48\x00\x49\x00\x0b\x01\x4b\x00\x4c\x00\x48\x00\x49\x00\xdf\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x83\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x29\x01\x57\x00\x2a\x01\x2b\x01\xbf\x00\x2c\x01\x45\x00\x48\x00\x49\x00\xd0\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\xd1\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x62\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x7e\xff\x26\x01\x04\x00\x24\x01\x3c\x00\x04\x00\x0a\x01\x48\x00\x49\x00\x85\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\xb4\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x58\x00\x4d\x00\x84\x00\x46\x00\x47\x00\x19\x01\xbf\x00\x1a\x01\xbf\x00\x04\x00\xcd\x00\x7e\xff\x48\x00\x49\x00\xb5\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\x85\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\x02\x01\x4d\x00\x45\x00\x46\x00\x47\x00\x03\x01\x08\x01\x0e\x00\xe1\x00\x04\x00\xe6\x00\xe7\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x48\x00\x49\x00\x64\x00\x4b\x00\x4c\x00\x4d\x00\x45\x00\x46\x00\x47\x00\xe8\x00\x4d\x00\x0b\x00\x58\x00\x0d\x00\xef\x00\xf2\x00\xf3\x00\x04\x00\xc3\x00\x04\x00\xbf\x00\x48\x00\xcd\x00\xce\x00\x88\x00\x4c\x00\x15\x00\xdb\x00\x1e\x00\x95\x00\x90\x00\x4d\x00\x04\x00\x97\x00\x96\x00\x99\x00\x04\x00\x58\x00\xaf\x00\xb1\x00\xb0\x00\xb2\x00\xb4\x00\xb7\x00\x04\x00\x04\x00\x70\x00\xb9\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x04\x00\x76\x00\x77\x00\x58\x00\x7f\x00\x80\x00\x8b\x00\x8c\x00\x8e\x00\x58\x00\x04\x00\x6d\x00\x04\x00\x3d\x00\x04\x00\x30\x00\x6b\x00\x6d\x00\x33\x00\x35\x00\x36\x00\x38\x00\x39\x00\x34\x00\x37\x00\x3b\x00\x3a\x00\x3f\x00\x2b\x00\x40\x00\x41\x00\xff\xff\x2c\x00\x00\x00\x2d\x00\x04\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 146) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146) + ] + +happy_n_terms = 55 :: Int +happy_n_nonterms = 55 :: Int + +happyReduce_2 = happySpecReduce_1 0# happyReduction_2 +happyReduction_2 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> + happyIn5 + (identC happy_var_1 --H + )} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> + happyIn6 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_1 2# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> + happyIn7 + ((read happy_var_1) :: Integer + )} + +happyReduce_5 = happySpecReduce_1 3# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> + happyIn8 + ((read happy_var_1) :: Double + )} + +happyReduce_6 = happyReduce 6# 4# happyReduction_6 +happyReduction_6 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut59 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + case happyOut13 happy_x_6 of { happy_var_6 -> + happyIn9 + (MGr happy_var_2 happy_var_4 (reverse happy_var_6) + ) `HappyStk` happyRest}}} + +happyReduce_7 = happySpecReduce_1 4# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn9 + (Gr (reverse happy_var_1) + )} + +happyReduce_8 = happyReduce 5# 5# happyReduction_8 +happyReduction_8 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut59 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + happyIn10 + (LMulti happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_9 = happyReduce 5# 5# happyReduction_9 +happyReduction_9 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_3 of { happy_var_3 -> + case happyOut15 happy_x_4 of { happy_var_4 -> + happyIn10 + (LHeader happy_var_1 happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_10 = happySpecReduce_2 5# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + happyIn10 + (LFlag happy_var_1 + )} + +happyReduce_11 = happySpecReduce_2 5# happyReduction_11 +happyReduction_11 happy_x_2 + happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + happyIn10 + (LDef happy_var_1 + )} + +happyReduce_12 = happySpecReduce_1 5# happyReduction_12 +happyReduction_12 happy_x_1 + = happyIn10 + (LEnd + ) + +happyReduce_13 = happyReduce 8# 6# happyReduction_13 +happyReduction_13 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_3 of { happy_var_3 -> + case happyOut15 happy_x_4 of { happy_var_4 -> + case happyOut45 happy_x_6 of { happy_var_6 -> + case happyOut46 happy_x_7 of { happy_var_7 -> + happyIn11 + (Mod happy_var_1 happy_var_3 happy_var_4 (reverse happy_var_6) (reverse happy_var_7) + ) `HappyStk` happyRest}}}}} + +happyReduce_14 = happySpecReduce_2 7# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn12 + (MTAbs happy_var_2 + )} + +happyReduce_15 = happyReduce 4# 7# happyReduction_15 +happyReduction_15 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + happyIn12 + (MTCnc happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_16 = happySpecReduce_2 7# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn12 + (MTRes happy_var_2 + )} + +happyReduce_17 = happyReduce 6# 7# happyReduction_17 +happyReduction_17 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + case happyOut5 happy_x_6 of { happy_var_6 -> + happyIn12 + (MTTrans happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest}}} + +happyReduce_18 = happySpecReduce_0 8# happyReduction_18 +happyReduction_18 = happyIn13 + ([] + ) + +happyReduce_19 = happySpecReduce_2 8# happyReduction_19 +happyReduction_19 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn13 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_20 = happySpecReduce_2 9# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = case happyOut59 happy_x_1 of { happy_var_1 -> + happyIn14 + (Ext happy_var_1 + )} + +happyReduce_21 = happySpecReduce_0 9# happyReduction_21 +happyReduction_21 = happyIn14 + (NoExt + ) + +happyReduce_22 = happySpecReduce_3 10# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut59 happy_x_2 of { happy_var_2 -> + happyIn15 + (Opens happy_var_2 + )} + +happyReduce_23 = happySpecReduce_0 10# happyReduction_23 +happyReduction_23 = happyIn15 + (NoOpens + ) + +happyReduce_24 = happyReduce 4# 11# happyReduction_24 +happyReduction_24 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + happyIn16 + (Flg happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_25 = happyReduce 7# 12# happyReduction_25 +happyReduction_25 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut27 happy_x_4 of { happy_var_4 -> + case happyOut49 happy_x_7 of { happy_var_7 -> + happyIn17 + (AbsDCat happy_var_2 happy_var_4 (reverse happy_var_7) + ) `HappyStk` happyRest}}} + +happyReduce_26 = happyReduce 6# 12# happyReduction_26 +happyReduction_26 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut22 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_6 of { happy_var_6 -> + happyIn17 + (AbsDFun happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest}}} + +happyReduce_27 = happyReduce 4# 12# happyReduction_27 +happyReduction_27 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut22 happy_x_4 of { happy_var_4 -> + happyIn17 + (AbsDTrans happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_28 = happyReduce 4# 12# happyReduction_28 +happyReduction_28 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut47 happy_x_4 of { happy_var_4 -> + happyIn17 + (ResDPar happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_29 = happyReduce 6# 12# happyReduction_29 +happyReduction_29 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_4 of { happy_var_4 -> + case happyOut36 happy_x_6 of { happy_var_6 -> + happyIn17 + (ResDOper happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest}}} + +happyReduce_30 = happyReduce 8# 12# happyReduction_30 +happyReduction_30 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_4 of { happy_var_4 -> + case happyOut36 happy_x_6 of { happy_var_6 -> + case happyOut36 happy_x_8 of { happy_var_8 -> + happyIn17 + (CncDCat happy_var_2 happy_var_4 happy_var_6 happy_var_8 + ) `HappyStk` happyRest}}}} + +happyReduce_31 = happyReduce 11# 12# happyReduction_31 +happyReduction_31 (happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut20 happy_x_4 of { happy_var_4 -> + case happyOut51 happy_x_7 of { happy_var_7 -> + case happyOut36 happy_x_9 of { happy_var_9 -> + case happyOut36 happy_x_11 of { happy_var_11 -> + happyIn17 + (CncDFun happy_var_2 happy_var_4 happy_var_7 happy_var_9 happy_var_11 + ) `HappyStk` happyRest}}}}} + +happyReduce_32 = happyReduce 4# 12# happyReduction_32 +happyReduction_32 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + happyIn17 + (AnyDInd happy_var_1 happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_33 = happySpecReduce_2 13# happyReduction_33 +happyReduction_33 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn18 + (ParD happy_var_1 (reverse happy_var_2) + )}} + +happyReduce_34 = happySpecReduce_1 14# happyReduction_34 +happyReduction_34 happy_x_1 + = happyIn19 + (Canon + ) + +happyReduce_35 = happySpecReduce_0 14# happyReduction_35 +happyReduction_35 = happyIn19 + (NonCan + ) + +happyReduce_36 = happySpecReduce_3 15# happyReduction_36 +happyReduction_36 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn20 + (CIQ happy_var_1 happy_var_3 + )}} + +happyReduce_37 = happySpecReduce_2 16# happyReduction_37 +happyReduction_37 happy_x_2 + happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn21 + (EApp happy_var_1 happy_var_2 + )}} + +happyReduce_38 = happySpecReduce_1 16# happyReduction_38 +happyReduction_38 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn21 + (happy_var_1 + )} + +happyReduce_39 = happyReduce 7# 17# happyReduction_39 +happyReduction_39 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut22 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_7 of { happy_var_7 -> + happyIn22 + (EProd happy_var_2 happy_var_4 happy_var_7 + ) `HappyStk` happyRest}}} + +happyReduce_40 = happyReduce 4# 17# happyReduction_40 +happyReduction_40 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOut22 happy_x_4 of { happy_var_4 -> + happyIn22 + (EAbs happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_41 = happySpecReduce_3 17# happyReduction_41 +happyReduction_41 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_2 of { happy_var_2 -> + happyIn22 + (EEq (reverse happy_var_2) + )} + +happyReduce_42 = happySpecReduce_1 17# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn22 + (happy_var_1 + )} + +happyReduce_43 = happySpecReduce_1 18# happyReduction_43 +happyReduction_43 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn23 + (EAtom happy_var_1 + )} + +happyReduce_44 = happySpecReduce_1 18# happyReduction_44 +happyReduction_44 happy_x_1 + = happyIn23 + (EData + ) + +happyReduce_45 = happySpecReduce_3 18# happyReduction_45 +happyReduction_45 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn23 + (happy_var_2 + )} + +happyReduce_46 = happySpecReduce_1 19# happyReduction_46 +happyReduction_46 happy_x_1 + = happyIn24 + (SType + ) + +happyReduce_47 = happySpecReduce_3 20# happyReduction_47 +happyReduction_47 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_3 of { happy_var_3 -> + happyIn25 + (Equ (reverse happy_var_1) happy_var_3 + )}} + +happyReduce_48 = happyReduce 4# 21# happyReduction_48 +happyReduction_48 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOut28 happy_x_3 of { happy_var_3 -> + happyIn26 + (APC happy_var_2 (reverse happy_var_3) + ) `HappyStk` happyRest}} + +happyReduce_49 = happySpecReduce_1 21# happyReduction_49 +happyReduction_49 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn26 + (APV happy_var_1 + )} + +happyReduce_50 = happySpecReduce_1 21# happyReduction_50 +happyReduction_50 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn26 + (APS happy_var_1 + )} + +happyReduce_51 = happySpecReduce_1 21# happyReduction_51 +happyReduction_51 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn26 + (API happy_var_1 + )} + +happyReduce_52 = happySpecReduce_1 21# happyReduction_52 +happyReduction_52 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn26 + (APF happy_var_1 + )} + +happyReduce_53 = happySpecReduce_1 21# happyReduction_53 +happyReduction_53 happy_x_1 + = happyIn26 + (APW + ) + +happyReduce_54 = happySpecReduce_0 22# happyReduction_54 +happyReduction_54 = happyIn27 + ([] + ) + +happyReduce_55 = happySpecReduce_1 22# happyReduction_55 +happyReduction_55 happy_x_1 + = case happyOut31 happy_x_1 of { happy_var_1 -> + happyIn27 + ((:[]) happy_var_1 + )} + +happyReduce_56 = happySpecReduce_3 22# happyReduction_56 +happyReduction_56 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut31 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn27 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_57 = happySpecReduce_0 23# happyReduction_57 +happyReduction_57 = happyIn28 + ([] + ) + +happyReduce_58 = happySpecReduce_2 23# happyReduction_58 +happyReduction_58 happy_x_2 + happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + case happyOut26 happy_x_2 of { happy_var_2 -> + happyIn28 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_59 = happySpecReduce_0 24# happyReduction_59 +happyReduction_59 = happyIn29 + ([] + ) + +happyReduce_60 = happySpecReduce_3 24# happyReduction_60 +happyReduction_60 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_2 of { happy_var_2 -> + happyIn29 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_61 = happySpecReduce_1 25# happyReduction_61 +happyReduction_61 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn30 + (AC happy_var_1 + )} + +happyReduce_62 = happySpecReduce_3 25# happyReduction_62 +happyReduction_62 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut20 happy_x_2 of { happy_var_2 -> + happyIn30 + (AD happy_var_2 + )} + +happyReduce_63 = happySpecReduce_2 25# happyReduction_63 +happyReduction_63 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn30 + (AV happy_var_2 + )} + +happyReduce_64 = happySpecReduce_2 25# happyReduction_64 +happyReduction_64 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn30 + (AM happy_var_2 + )} + +happyReduce_65 = happySpecReduce_1 25# happyReduction_65 +happyReduction_65 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn30 + (AS happy_var_1 + )} + +happyReduce_66 = happySpecReduce_1 25# happyReduction_66 +happyReduction_66 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn30 + (AI happy_var_1 + )} + +happyReduce_67 = happySpecReduce_1 25# happyReduction_67 +happyReduction_67 happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + happyIn30 + (AT happy_var_1 + )} + +happyReduce_68 = happySpecReduce_3 26# happyReduction_68 +happyReduction_68 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_3 of { happy_var_3 -> + happyIn31 + (Decl happy_var_1 happy_var_3 + )}} + +happyReduce_69 = happySpecReduce_3 27# happyReduction_69 +happyReduction_69 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut52 happy_x_2 of { happy_var_2 -> + happyIn32 + (RecType happy_var_2 + )} + +happyReduce_70 = happyReduce 5# 27# happyReduction_70 +happyReduction_70 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_4 of { happy_var_4 -> + happyIn32 + (Table happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_71 = happySpecReduce_1 27# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn32 + (Cn happy_var_1 + )} + +happyReduce_72 = happySpecReduce_1 27# happyReduction_72 +happyReduction_72 happy_x_1 + = happyIn32 + (TStr + ) + +happyReduce_73 = happySpecReduce_2 27# happyReduction_73 +happyReduction_73 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn32 + (TInts happy_var_2 + )} + +happyReduce_74 = happySpecReduce_3 28# happyReduction_74 +happyReduction_74 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn33 + (Lbg happy_var_1 happy_var_3 + )}} + +happyReduce_75 = happySpecReduce_1 29# happyReduction_75 +happyReduction_75 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn34 + (Arg happy_var_1 + )} + +happyReduce_76 = happySpecReduce_1 29# happyReduction_76 +happyReduction_76 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn34 + (I happy_var_1 + )} + +happyReduce_77 = happyReduce 4# 29# happyReduction_77 +happyReduction_77 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn34 + (Par happy_var_2 (reverse happy_var_3) + ) `HappyStk` happyRest}} + +happyReduce_78 = happySpecReduce_2 29# happyReduction_78 +happyReduction_78 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn34 + (LI happy_var_2 + )} + +happyReduce_79 = happySpecReduce_3 29# happyReduction_79 +happyReduction_79 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_2 of { happy_var_2 -> + happyIn34 + (R happy_var_2 + )} + +happyReduce_80 = happySpecReduce_1 29# happyReduction_80 +happyReduction_80 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn34 + (EInt happy_var_1 + )} + +happyReduce_81 = happySpecReduce_1 29# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn34 + (EFloat happy_var_1 + )} + +happyReduce_82 = happySpecReduce_1 29# happyReduction_82 +happyReduction_82 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn34 + (K happy_var_1 + )} + +happyReduce_83 = happySpecReduce_2 29# happyReduction_83 +happyReduction_83 happy_x_2 + happy_x_1 + = happyIn34 + (E + ) + +happyReduce_84 = happySpecReduce_3 29# happyReduction_84 +happyReduction_84 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn34 + (happy_var_2 + )} + +happyReduce_85 = happySpecReduce_3 30# happyReduction_85 +happyReduction_85 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut34 happy_x_1 of { happy_var_1 -> + case happyOut41 happy_x_3 of { happy_var_3 -> + happyIn35 + (P happy_var_1 happy_var_3 + )}} + +happyReduce_86 = happyReduce 5# 30# happyReduction_86 +happyReduction_86 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut53 happy_x_4 of { happy_var_4 -> + happyIn35 + (T happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_87 = happyReduce 5# 30# happyReduction_87 +happyReduction_87 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut54 happy_x_4 of { happy_var_4 -> + happyIn35 + (V happy_var_2 (reverse happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_88 = happySpecReduce_3 30# happyReduction_88 +happyReduction_88 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_3 of { happy_var_3 -> + happyIn35 + (S happy_var_1 happy_var_3 + )}} + +happyReduce_89 = happyReduce 4# 30# happyReduction_89 +happyReduction_89 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn35 + (FV (reverse happy_var_3) + ) `HappyStk` happyRest} + +happyReduce_90 = happySpecReduce_1 30# happyReduction_90 +happyReduction_90 happy_x_1 + = case happyOut34 happy_x_1 of { happy_var_1 -> + happyIn35 + (happy_var_1 + )} + +happyReduce_91 = happySpecReduce_3 31# happyReduction_91 +happyReduction_91 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn36 + (C happy_var_1 happy_var_3 + )}} + +happyReduce_92 = happySpecReduce_1 31# happyReduction_92 +happyReduction_92 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn36 + (happy_var_1 + )} + +happyReduce_93 = happySpecReduce_1 32# happyReduction_93 +happyReduction_93 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn37 + (KS happy_var_1 + )} + +happyReduce_94 = happyReduce 7# 32# happyReduction_94 +happyReduction_94 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut55 happy_x_3 of { happy_var_3 -> + case happyOut56 happy_x_5 of { happy_var_5 -> + happyIn37 + (KP (reverse happy_var_3) happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_95 = happySpecReduce_3 33# happyReduction_95 +happyReduction_95 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn38 + (Ass happy_var_1 happy_var_3 + )}} + +happyReduce_96 = happySpecReduce_3 34# happyReduction_96 +happyReduction_96 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn39 + (Cas (reverse happy_var_1) happy_var_3 + )}} + +happyReduce_97 = happySpecReduce_3 35# happyReduction_97 +happyReduction_97 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn40 + (Var (reverse happy_var_1) (reverse happy_var_3) + )}} + +happyReduce_98 = happySpecReduce_1 36# happyReduction_98 +happyReduction_98 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn41 + (L happy_var_1 + )} + +happyReduce_99 = happySpecReduce_2 36# happyReduction_99 +happyReduction_99 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn41 + (LV happy_var_2 + )} + +happyReduce_100 = happySpecReduce_3 37# happyReduction_100 +happyReduction_100 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn42 + (A happy_var_1 happy_var_3 + )}} + +happyReduce_101 = happyReduce 5# 37# happyReduction_101 +happyReduction_101 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + case happyOut7 happy_x_5 of { happy_var_5 -> + happyIn42 + (AB happy_var_1 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_102 = happyReduce 4# 38# happyReduction_102 +happyReduction_102 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + happyIn43 + (PC happy_var_2 (reverse happy_var_3) + ) `HappyStk` happyRest}} + +happyReduce_103 = happySpecReduce_1 38# happyReduction_103 +happyReduction_103 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn43 + (PV happy_var_1 + )} + +happyReduce_104 = happySpecReduce_1 38# happyReduction_104 +happyReduction_104 happy_x_1 + = happyIn43 + (PW + ) + +happyReduce_105 = happySpecReduce_3 38# happyReduction_105 +happyReduction_105 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut57 happy_x_2 of { happy_var_2 -> + happyIn43 + (PR happy_var_2 + )} + +happyReduce_106 = happySpecReduce_1 38# happyReduction_106 +happyReduction_106 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn43 + (PI happy_var_1 + )} + +happyReduce_107 = happySpecReduce_1 38# happyReduction_107 +happyReduction_107 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn43 + (PF happy_var_1 + )} + +happyReduce_108 = happySpecReduce_3 39# happyReduction_108 +happyReduction_108 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_3 of { happy_var_3 -> + happyIn44 + (PAss happy_var_1 happy_var_3 + )}} + +happyReduce_109 = happySpecReduce_0 40# happyReduction_109 +happyReduction_109 = happyIn45 + ([] + ) + +happyReduce_110 = happySpecReduce_3 40# happyReduction_110 +happyReduction_110 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn45 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_111 = happySpecReduce_0 41# happyReduction_111 +happyReduction_111 = happyIn46 + ([] + ) + +happyReduce_112 = happySpecReduce_3 41# happyReduction_112 +happyReduction_112 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn46 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_113 = happySpecReduce_0 42# happyReduction_113 +happyReduction_113 = happyIn47 + ([] + ) + +happyReduce_114 = happySpecReduce_1 42# happyReduction_114 +happyReduction_114 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn47 + ((:[]) happy_var_1 + )} + +happyReduce_115 = happySpecReduce_3 42# happyReduction_115 +happyReduction_115 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn47 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_116 = happySpecReduce_0 43# happyReduction_116 +happyReduction_116 = happyIn48 + ([] + ) + +happyReduce_117 = happySpecReduce_2 43# happyReduction_117 +happyReduction_117 happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn48 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_118 = happySpecReduce_0 44# happyReduction_118 +happyReduction_118 = happyIn49 + ([] + ) + +happyReduce_119 = happySpecReduce_2 44# happyReduction_119 +happyReduction_119 happy_x_2 + happy_x_1 + = case happyOut49 happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_2 of { happy_var_2 -> + happyIn49 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_120 = happySpecReduce_0 45# happyReduction_120 +happyReduction_120 = happyIn50 + ([] + ) + +happyReduce_121 = happySpecReduce_1 45# happyReduction_121 +happyReduction_121 happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn50 + ((:[]) happy_var_1 + )} + +happyReduce_122 = happySpecReduce_3 45# happyReduction_122 +happyReduction_122 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn50 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_123 = happySpecReduce_0 46# happyReduction_123 +happyReduction_123 = happyIn51 + ([] + ) + +happyReduce_124 = happySpecReduce_1 46# happyReduction_124 +happyReduction_124 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn51 + ((:[]) happy_var_1 + )} + +happyReduce_125 = happySpecReduce_3 46# happyReduction_125 +happyReduction_125 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_3 of { happy_var_3 -> + happyIn51 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_126 = happySpecReduce_0 47# happyReduction_126 +happyReduction_126 = happyIn52 + ([] + ) + +happyReduce_127 = happySpecReduce_1 47# happyReduction_127 +happyReduction_127 happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + happyIn52 + ((:[]) happy_var_1 + )} + +happyReduce_128 = happySpecReduce_3 47# happyReduction_128 +happyReduction_128 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut52 happy_x_3 of { happy_var_3 -> + happyIn52 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_129 = happySpecReduce_0 48# happyReduction_129 +happyReduction_129 = happyIn53 + ([] + ) + +happyReduce_130 = happySpecReduce_1 48# happyReduction_130 +happyReduction_130 happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn53 + ((:[]) happy_var_1 + )} + +happyReduce_131 = happySpecReduce_3 48# happyReduction_131 +happyReduction_131 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_3 of { happy_var_3 -> + happyIn53 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_132 = happySpecReduce_0 49# happyReduction_132 +happyReduction_132 = happyIn54 + ([] + ) + +happyReduce_133 = happySpecReduce_2 49# happyReduction_133 +happyReduction_133 happy_x_2 + happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn54 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_134 = happySpecReduce_0 50# happyReduction_134 +happyReduction_134 = happyIn55 + ([] + ) + +happyReduce_135 = happySpecReduce_2 50# happyReduction_135 +happyReduction_135 happy_x_2 + happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn55 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_136 = happySpecReduce_0 51# happyReduction_136 +happyReduction_136 = happyIn56 + ([] + ) + +happyReduce_137 = happySpecReduce_1 51# happyReduction_137 +happyReduction_137 happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn56 + ((:[]) happy_var_1 + )} + +happyReduce_138 = happySpecReduce_3 51# happyReduction_138 +happyReduction_138 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_3 of { happy_var_3 -> + happyIn56 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_139 = happySpecReduce_0 52# happyReduction_139 +happyReduction_139 = happyIn57 + ([] + ) + +happyReduce_140 = happySpecReduce_1 52# happyReduction_140 +happyReduction_140 happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + happyIn57 + ((:[]) happy_var_1 + )} + +happyReduce_141 = happySpecReduce_3 52# happyReduction_141 +happyReduction_141 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOut57 happy_x_3 of { happy_var_3 -> + happyIn57 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_142 = happySpecReduce_0 53# happyReduction_142 +happyReduction_142 = happyIn58 + ([] + ) + +happyReduce_143 = happySpecReduce_2 53# happyReduction_143 +happyReduction_143 happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_2 of { happy_var_2 -> + happyIn58 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_144 = happySpecReduce_0 54# happyReduction_144 +happyReduction_144 = happyIn59 + ([] + ) + +happyReduce_145 = happySpecReduce_1 54# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn59 + ((:[]) happy_var_1 + )} + +happyReduce_146 = happySpecReduce_3 54# happyReduction_146 +happyReduction_146 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut59 happy_x_3 of { happy_var_3 -> + happyIn59 + ((:) happy_var_1 happy_var_3 + )}} + +happyNewToken action sts stk [] = + happyDoAction 54# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + PT _ (TS ";") -> cont 1#; + PT _ (TS "=") -> cont 2#; + PT _ (TS "{") -> cont 3#; + PT _ (TS "}") -> cont 4#; + PT _ (TS ":") -> cont 5#; + PT _ (TS "->") -> cont 6#; + PT _ (TS "**") -> cont 7#; + PT _ (TS "[") -> cont 8#; + PT _ (TS "]") -> cont 9#; + PT _ (TS "\\") -> cont 10#; + PT _ (TS ".") -> cont 11#; + PT _ (TS "(") -> cont 12#; + PT _ (TS ")") -> cont 13#; + PT _ (TS "_") -> cont 14#; + PT _ (TS "<") -> cont 15#; + PT _ (TS ">") -> cont 16#; + PT _ (TS "$") -> cont 17#; + PT _ (TS "?") -> cont 18#; + PT _ (TS "=>") -> cont 19#; + PT _ (TS "!") -> cont 20#; + PT _ (TS "++") -> cont 21#; + PT _ (TS "/") -> cont 22#; + PT _ (TS "@") -> cont 23#; + PT _ (TS "+") -> cont 24#; + PT _ (TS "|") -> cont 25#; + PT _ (TS ",") -> cont 26#; + PT _ (TS "Ints") -> cont 27#; + PT _ (TS "Str") -> cont 28#; + PT _ (TS "Type") -> cont 29#; + PT _ (TS "abstract") -> cont 30#; + PT _ (TS "cat") -> cont 31#; + PT _ (TS "concrete") -> cont 32#; + PT _ (TS "data") -> cont 33#; + PT _ (TS "flags") -> cont 34#; + PT _ (TS "fun") -> cont 35#; + PT _ (TS "grammar") -> cont 36#; + PT _ (TS "in") -> cont 37#; + PT _ (TS "lin") -> cont 38#; + PT _ (TS "lincat") -> cont 39#; + PT _ (TS "of") -> cont 40#; + PT _ (TS "open") -> cont 41#; + PT _ (TS "oper") -> cont 42#; + PT _ (TS "param") -> cont 43#; + PT _ (TS "pre") -> cont 44#; + PT _ (TS "resource") -> cont 45#; + PT _ (TS "table") -> cont 46#; + PT _ (TS "transfer") -> cont 47#; + PT _ (TS "variants") -> cont 48#; + PT _ (TV happy_dollar_dollar) -> cont 49#; + PT _ (TL happy_dollar_dollar) -> cont 50#; + PT _ (TI happy_dollar_dollar) -> cont 51#; + PT _ (TD happy_dollar_dollar) -> cont 52#; + _ -> cont 53#; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = (thenM) +happyReturn :: () => a -> Err a +happyReturn = (returnM) +happyThen1 m k tks = (thenM) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (returnM) a +happyError' :: () => [Token] -> Err a +happyError' = happyError + +pCanon tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut9 x)) + +pLine tks = happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut10 x)) + +happySeq = happyDontSeq + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) + +myLexer = tokens +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id$ + + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + + +{-# LINE 59 "GenericTemplate.hs" #-} + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src-3.0/GF/Canon/ParGFC.y b/src-3.0/GF/Canon/ParGFC.y new file mode 100644 index 000000000..6432a8696 --- /dev/null +++ b/src-3.0/GF/Canon/ParGFC.y @@ -0,0 +1,385 @@ +-- This Happy file was machine-generated by the BNF converter +{ +module GF.Canon.ParGFC where +import GF.Canon.AbsGFC +import GF.Canon.LexGFC +import GF.Data.ErrM -- H +import GF.Infra.Ident -- H +} + +%name pCanon Canon +%name pLine Line + +-- no lexer declaration +%monad { Err } { thenM } { returnM } +%tokentype { Token } + +%token + ';' { PT _ (TS ";") } + '=' { PT _ (TS "=") } + '{' { PT _ (TS "{") } + '}' { PT _ (TS "}") } + ':' { PT _ (TS ":") } + '->' { PT _ (TS "->") } + '**' { PT _ (TS "**") } + '[' { PT _ (TS "[") } + ']' { PT _ (TS "]") } + '\\' { PT _ (TS "\\") } + '.' { PT _ (TS ".") } + '(' { PT _ (TS "(") } + ')' { PT _ (TS ")") } + '_' { PT _ (TS "_") } + '<' { PT _ (TS "<") } + '>' { PT _ (TS ">") } + '$' { PT _ (TS "$") } + '?' { PT _ (TS "?") } + '=>' { PT _ (TS "=>") } + '!' { PT _ (TS "!") } + '++' { PT _ (TS "++") } + '/' { PT _ (TS "/") } + '@' { PT _ (TS "@") } + '+' { PT _ (TS "+") } + '|' { PT _ (TS "|") } + ',' { PT _ (TS ",") } + 'Ints' { PT _ (TS "Ints") } + 'Str' { PT _ (TS "Str") } + 'Type' { PT _ (TS "Type") } + 'abstract' { PT _ (TS "abstract") } + 'cat' { PT _ (TS "cat") } + 'concrete' { PT _ (TS "concrete") } + 'data' { PT _ (TS "data") } + 'flags' { PT _ (TS "flags") } + 'fun' { PT _ (TS "fun") } + 'grammar' { PT _ (TS "grammar") } + 'in' { PT _ (TS "in") } + 'lin' { PT _ (TS "lin") } + 'lincat' { PT _ (TS "lincat") } + 'of' { PT _ (TS "of") } + 'open' { PT _ (TS "open") } + 'oper' { PT _ (TS "oper") } + 'param' { PT _ (TS "param") } + 'pre' { PT _ (TS "pre") } + 'resource' { PT _ (TS "resource") } + 'table' { PT _ (TS "table") } + 'transfer' { PT _ (TS "transfer") } + 'variants' { PT _ (TS "variants") } + +L_ident { PT _ (TV $$) } +L_quoted { PT _ (TL $$) } +L_integ { PT _ (TI $$) } +L_err { _ } + + +%% + +Ident :: { Ident } : L_ident { identC $1 } -- H +String :: { String } : L_quoted { $1 } +Integer :: { Integer } : L_integ { (read $1) :: Integer } + +Canon :: { Canon } +Canon : 'grammar' ListIdent 'of' Ident ';' ListModule { MGr $2 $4 (reverse $6) } + | ListModule { Gr (reverse $1) } + + +Line :: { Line } +Line : 'grammar' ListIdent 'of' Ident ';' { LMulti $2 $4 } + | ModType '=' Extend Open '{' { LHeader $1 $3 $4 } + | Flag ';' { LFlag $1 } + | Def ';' { LDef $1 } + | '}' { LEnd } + + +Module :: { Module } +Module : ModType '=' Extend Open '{' ListFlag ListDef '}' { Mod $1 $3 $4 (reverse $6) (reverse $7) } + + +ModType :: { ModType } +ModType : 'abstract' Ident { MTAbs $2 } + | 'concrete' Ident 'of' Ident { MTCnc $2 $4 } + | 'resource' Ident { MTRes $2 } + | 'transfer' Ident ':' Ident '->' Ident { MTTrans $2 $4 $6 } + + +ListModule :: { [Module] } +ListModule : {- empty -} { [] } + | ListModule Module { flip (:) $1 $2 } + + +Extend :: { Extend } +Extend : ListIdent '**' { Ext $1 } + | {- empty -} { NoExt } + + +Open :: { Open } +Open : 'open' ListIdent 'in' { Opens $2 } + | {- empty -} { NoOpens } + + +Flag :: { Flag } +Flag : 'flags' Ident '=' Ident { Flg $2 $4 } + + +Def :: { Def } +Def : 'cat' Ident '[' ListDecl ']' '=' ListCIdent { AbsDCat $2 $4 (reverse $7) } + | 'fun' Ident ':' Exp '=' Exp { AbsDFun $2 $4 $6 } + | 'transfer' Ident '=' Exp { AbsDTrans $2 $4 } + | 'param' Ident '=' ListParDef { ResDPar $2 $4 } + | 'oper' Ident ':' CType '=' Term { ResDOper $2 $4 $6 } + | 'lincat' Ident '=' CType '=' Term ';' Term { CncDCat $2 $4 $6 $8 } + | 'lin' Ident ':' CIdent '=' '\\' ListArgVar '->' Term ';' Term { CncDFun $2 $4 $7 $9 $11 } + | Ident Status 'in' Ident { AnyDInd $1 $2 $4 } + + +ParDef :: { ParDef } +ParDef : Ident ListCType { ParD $1 (reverse $2) } + + +Status :: { Status } +Status : 'data' { Canon } + | {- empty -} { NonCan } + + +CIdent :: { CIdent } +CIdent : Ident '.' Ident { CIQ $1 $3 } + + +Exp1 :: { Exp } +Exp1 : Exp1 Exp2 { EApp $1 $2 } + | Exp2 { $1 } + + +Exp :: { Exp } +Exp : '(' Ident ':' Exp ')' '->' Exp { EProd $2 $4 $7 } + | '\\' Ident '->' Exp { EAbs $2 $4 } + | '{' ListEquation '}' { EEq (reverse $2) } + | Exp1 { $1 } + + +Exp2 :: { Exp } +Exp2 : Atom { EAtom $1 } + | 'data' { EData } + | '(' Exp ')' { $2 } + + +Sort :: { Sort } +Sort : 'Type' { SType } + + +Equation :: { Equation } +Equation : ListAPatt '->' Exp { Equ (reverse $1) $3 } + + +APatt :: { APatt } +APatt : '(' CIdent ListAPatt ')' { APC $2 (reverse $3) } + | Ident { APV $1 } + | String { APS $1 } + | Integer { API $1 } + | '_' { APW } + + +ListDecl :: { [Decl] } +ListDecl : {- empty -} { [] } + | Decl { (:[]) $1 } + | Decl ';' ListDecl { (:) $1 $3 } + + +ListAPatt :: { [APatt] } +ListAPatt : {- empty -} { [] } + | ListAPatt APatt { flip (:) $1 $2 } + + +ListEquation :: { [Equation] } +ListEquation : {- empty -} { [] } + | ListEquation Equation ';' { flip (:) $1 $2 } + + +Atom :: { Atom } +Atom : CIdent { AC $1 } + | '<' CIdent '>' { AD $2 } + | '$' Ident { AV $2 } + | '?' Integer { AM $2 } + | String { AS $1 } + | Integer { AI $1 } + | Sort { AT $1 } + + +Decl :: { Decl } +Decl : Ident ':' Exp { Decl $1 $3 } + + +CType :: { CType } +CType : '{' ListLabelling '}' { RecType $2 } + | '(' CType '=>' CType ')' { Table $2 $4 } + | CIdent { Cn $1 } + | 'Str' { TStr } + | 'Ints' Integer { TInts $2 } + + +Labelling :: { Labelling } +Labelling : Label ':' CType { Lbg $1 $3 } + + +Term2 :: { Term } +Term2 : ArgVar { Arg $1 } + | CIdent { I $1 } + | '<' CIdent ListTerm2 '>' { Par $2 (reverse $3) } + | '$' Ident { LI $2 } + | '{' ListAssign '}' { R $2 } + | Integer { EInt $1 } + | Tokn { K $1 } + | '[' ']' { E } + | '(' Term ')' { $2 } + + +Term1 :: { Term } +Term1 : Term2 '.' Label { P $1 $3 } + | 'table' CType '{' ListCase '}' { T $2 $4 } + | 'table' CType '[' ListTerm2 ']' { V $2 (reverse $4) } + | Term1 '!' Term2 { S $1 $3 } + | 'variants' '{' ListTerm2 '}' { FV (reverse $3) } + | Term2 { $1 } + + +Term :: { Term } +Term : Term '++' Term1 { C $1 $3 } + | Term1 { $1 } + + +Tokn :: { Tokn } +Tokn : String { KS $1 } + | '[' 'pre' ListString '{' ListVariant '}' ']' { KP (reverse $3) $5 } + + +Assign :: { Assign } +Assign : Label '=' Term { Ass $1 $3 } + + +Case :: { Case } +Case : ListPatt '=>' Term { Cas (reverse $1) $3 } + + +Variant :: { Variant } +Variant : ListString '/' ListString { Var (reverse $1) (reverse $3) } + + +Label :: { Label } +Label : Ident { L $1 } + | '$' Integer { LV $2 } + + +ArgVar :: { ArgVar } +ArgVar : Ident '@' Integer { A $1 $3 } + | Ident '+' Integer '@' Integer { AB $1 $3 $5 } + + +Patt :: { Patt } +Patt : '(' CIdent ListPatt ')' { PC $2 (reverse $3) } + | Ident { PV $1 } + | '_' { PW } + | '{' ListPattAssign '}' { PR $2 } + | Integer { PI $1 } + + +PattAssign :: { PattAssign } +PattAssign : Label '=' Patt { PAss $1 $3 } + + +ListFlag :: { [Flag] } +ListFlag : {- empty -} { [] } + | ListFlag Flag ';' { flip (:) $1 $2 } + + +ListDef :: { [Def] } +ListDef : {- empty -} { [] } + | ListDef Def ';' { flip (:) $1 $2 } + + +ListParDef :: { [ParDef] } +ListParDef : {- empty -} { [] } + | ParDef { (:[]) $1 } + | ParDef '|' ListParDef { (:) $1 $3 } + + +ListCType :: { [CType] } +ListCType : {- empty -} { [] } + | ListCType CType { flip (:) $1 $2 } + + +ListCIdent :: { [CIdent] } +ListCIdent : {- empty -} { [] } + | ListCIdent CIdent { flip (:) $1 $2 } + + +ListAssign :: { [Assign] } +ListAssign : {- empty -} { [] } + | Assign { (:[]) $1 } + | Assign ';' ListAssign { (:) $1 $3 } + + +ListArgVar :: { [ArgVar] } +ListArgVar : {- empty -} { [] } + | ArgVar { (:[]) $1 } + | ArgVar ',' ListArgVar { (:) $1 $3 } + + +ListLabelling :: { [Labelling] } +ListLabelling : {- empty -} { [] } + | Labelling { (:[]) $1 } + | Labelling ';' ListLabelling { (:) $1 $3 } + + +ListCase :: { [Case] } +ListCase : {- empty -} { [] } + | Case { (:[]) $1 } + | Case ';' ListCase { (:) $1 $3 } + + +ListTerm2 :: { [Term] } +ListTerm2 : {- empty -} { [] } + | ListTerm2 Term2 { flip (:) $1 $2 } + + +ListString :: { [String] } +ListString : {- empty -} { [] } + | ListString String { flip (:) $1 $2 } + + +ListVariant :: { [Variant] } +ListVariant : {- empty -} { [] } + | Variant { (:[]) $1 } + | Variant ';' ListVariant { (:) $1 $3 } + + +ListPattAssign :: { [PattAssign] } +ListPattAssign : {- empty -} { [] } + | PattAssign { (:[]) $1 } + | PattAssign ';' ListPattAssign { (:) $1 $3 } + + +ListPatt :: { [Patt] } +ListPatt : {- empty -} { [] } + | ListPatt Patt { flip (:) $1 $2 } + + +ListIdent :: { [Ident] } +ListIdent : {- empty -} { [] } + | Ident { (:[]) $1 } + | Ident ',' ListIdent { (:) $1 $3 } + + + +{ + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts))) + +myLexer = tokens +} + diff --git a/src-3.0/GF/Canon/PrExp.hs b/src-3.0/GF/Canon/PrExp.hs new file mode 100644 index 000000000..6202a760e --- /dev/null +++ b/src-3.0/GF/Canon/PrExp.hs @@ -0,0 +1,46 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrExp +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:28 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.5 $ +-- +-- print trees without qualifications +----------------------------------------------------------------------------- + +module GF.Canon.PrExp (prExp) where + +import GF.Canon.AbsGFC +import GF.Canon.GFC + +import GF.Data.Operations + +prExp :: Exp -> String +prExp e = case e of + EApp f a -> pr1 f +++ pr2 a + EAbsR x b -> "\\" ++ prtt x +++ "->" +++ prExp b + EAbs x _ b -> prExp $ EAbsR x b + EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b + EAtomR a -> prAtom a + EAtom a _ -> prAtom a + _ -> prtt e + where + pr1 e = case e of + EAbsR _ _ -> prParenth $ prExp e + EAbs _ _ _ -> prParenth $ prExp e + EProd _ _ _ -> prParenth $ prExp e + _ -> prExp e + pr2 e = case e of + EApp _ _ -> prParenth $ prExp e + _ -> pr1 e + +prAtom a = case a of + AC c -> prCIdent c + AD c -> prCIdent c + _ -> prtt a + +prCIdent (CIQ _ c) = prtt c diff --git a/src-3.0/GF/Canon/PrintGFC.hs b/src-3.0/GF/Canon/PrintGFC.hs new file mode 100644 index 000000000..437f3a1e9 --- /dev/null +++ b/src-3.0/GF/Canon/PrintGFC.hs @@ -0,0 +1,376 @@ +module GF.Canon.PrintGFC where + + +-- pretty-printer generated by the BNF converter, except handhacked spacing --H + +import GF.Infra.Ident --H +import GF.Canon.AbsGFC +import Data.Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +docs :: ShowS -> Doc +docs x y = concatD [spc, doc x, spc ] y + +spc = doc (showString "&") + +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + "*" :ts -> realnew . rend i ts --H + "&":"&":ts -> showChar ' ' . rend i ts --H + "&" :ts -> rend i ts --H + t :ts -> showString t . rend i ts + _ -> id + realnew = showChar '\n' --H + +{- +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + "*NEW" :ts -> realnew . rend i ts --H + "<" :ts -> showString "<" . rend i ts --H + "$" :ts -> showString "$" . rend i ts --H + "?" :ts -> showString "?" . rend i ts --H + "[" :ts -> showChar '[' . rend i ts + "(" :ts -> showChar '(' . rend i ts + "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts + "}" : ";":ts -> new (i-1) . showChar '}' . showChar ';' . new (i-1) . rend (i-1) ts + "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts + ";" :ts -> showChar ';' . new i . rend i ts + t : "@" :ts -> showString t . showChar '@' . rend i ts + t : "," :ts -> showString t . showChar ',' . rend i ts + t : ")" :ts -> showString t . showChar ')' . rend i ts + t : "]" :ts -> showString t . showChar ']' . rend i ts + t : ">" :ts -> showString t . showChar '>' . rend i ts --H + t : "." :ts -> showString t . showChar '.' . rend i ts --H + t@"=>" :ts -> showString t . rend i ts --H + t@"->" :ts -> showString t . rend i ts --H + t :ts -> realspace t . rend i ts --H + _ -> id + space t = showString t . showChar ' ' -- H + realspace t = showString t . (\s -> if null s then "" else (' ':s)) -- H + new i s = s -- H + realnew = showChar '\n' --H +-} + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- the printer class does the job +class Print a where + prt :: Int -> a -> Doc + prtList :: [a] -> Doc + prtList = concatD . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') + prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q s = case s of + _ | s == q -> showChar '\\' . showChar s + '\\'-> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + _ -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Canon where + prt i e = case e of + MGr ids id modules -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc , doc (showString "of") , spc, prt 0 id , doc (showString ";") , prt 0 modules]) + Gr modules -> prPrec i 0 (concatD [prt 0 modules]) + + +instance Print Line where + prt i e = case e of + LMulti ids id -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc, doc (showString "of") , spc, prt 0 id , doc (showString ";")]) + LHeader modtype extend open -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{")]) + LFlag flag -> prPrec i 0 (concatD [prt 0 flag , doc (showString ";")]) + LDef def -> prPrec i 0 (concatD [prt 0 def , doc (showString ";")]) + LEnd -> prPrec i 0 (concatD [doc (showString "}")]) + + +instance Print Module where + prt i e = case e of + Mod modtype extend open flags defs -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{") , prt 0 flags , prt 0 defs , doc (showString "}")]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print ModType where + prt i e = case e of + MTAbs id -> prPrec i 0 (concatD [spc, doc (showString "abstract") , spc , prt 0 id]) + MTCnc id0 id -> prPrec i 0 (concatD [spc, doc (showString "concrete") , spc, prt 0 id0 , spc, doc (showString "of") , spc, prt 0 id]) + MTRes id -> prPrec i 0 (concatD [spc, doc (showString "resource") , spc, prt 0 id]) + MTTrans id0 id1 id -> prPrec i 0 (concatD [spc, doc (showString "transfer") , spc, prt 0 id0 , doc (showString ":") , prt 0 id1 , doc (showString "->") , prt 0 id]) + + +instance Print Extend where + prt i e = case e of + Ext ids -> prPrec i 0 (concatD [prt 0 ids , doc (showString "**")]) + NoExt -> prPrec i 0 (concatD []) + + +instance Print Open where + prt i e = case e of + Opens ids -> prPrec i 0 (concatD [spc, doc (showString "open") , spc, prt 0 ids , docs (showString "in")]) + NoOpens -> prPrec i 0 (concatD []) + + +instance Print Flag where + prt i e = case e of + Flg id0 id -> prPrec i 0 (concatD [spc, doc (showString "flags") , spc, prt 0 id0 , doc (showString "=") , prt 0 id]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Def where + prt i e = case e of + AbsDCat id decls cidents -> prPrec i 0 (concatD [docs (showString "cat") , prt 0 id , doc (showString "[") , prt 0 decls , doc (showString "]") , doc (showString "=") , prt 0 cidents]) + AbsDFun id exp0 exp -> prPrec i 0 (concatD [docs (showString "fun") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) + AbsDTrans id exp -> prPrec i 0 (concatD [docs (showString "transfer") , prt 0 id , doc (showString "=") , prt 0 exp]) + ResDPar id pardefs -> prPrec i 0 (concatD [docs (showString "param") , prt 0 id , doc (showString "=") , prt 0 pardefs]) + ResDOper id ctype term -> prPrec i 0 (concatD [docs (showString "oper") , prt 0 id , doc (showString ":") , prt 0 ctype , doc (showString "=") , prt 0 term]) + CncDCat id ctype term0 term -> prPrec i 0 (concatD [docs (showString "lincat") , prt 0 id , doc (showString "=") , prt 0 ctype , doc (showString "=") , prt 0 term0 , doc (showString ";") , prt 0 term]) + CncDFun id cident argvars term0 term -> prPrec i 0 (concatD [docs (showString "lin") , prt 0 id , doc (showString ":") , prt 0 cident , doc (showString "=") , doc (showString "\\") , prt 0 argvars , doc (showString "->") , prt 0 term0 , doc (showString ";") , prt 0 term]) + AnyDInd id0 status id -> prPrec i 0 (concatD [prt 0 id0 , prt 0 status , docs (showString "in") , prt 0 id]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , doc (showString ";"), doc (showString "*") , prt 0 xs]) -- H + + +instance Print ParDef where + prt i e = case e of + ParD id ctypes -> prPrec i 0 (concatD [prt 0 id , prt 0 ctypes]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) + +instance Print Status where + prt i e = case e of + Canon -> prPrec i 0 (concatD [docs (showString "data")]) + NonCan -> prPrec i 0 (concatD []) + + +instance Print CIdent where + prt i e = case e of + CIQ id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + EApp exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , prt 2 exp]) + EProd id exp0 exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp]) + EAbs id exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 id , doc (showString "->") , prt 0 exp]) + EAtom atom -> prPrec i 2 (concatD [prt 0 atom]) + EData -> prPrec i 2 (concatD [docs (showString "data")]) + EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , doc (showString "}")]) + + +instance Print Sort where + prt i e = case e of + SType -> prPrec i 0 (concatD [docs (showString "Type")]) + + +instance Print Equation where + prt i e = case e of + Equ apatts exp -> prPrec i 0 (concatD [prt 0 apatts , doc (showString "->") , prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print APatt where + prt i e = case e of + APC cident apatts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 apatts , doc (showString ")")]) + APV id -> prPrec i 0 (concatD [prt 0 id]) + APS str -> prPrec i 0 (concatD [prt 0 str]) + API n -> prPrec i 0 (concatD [prt 0 n]) + APF n -> prPrec i 0 (concatD [prt 0 n]) + APW -> prPrec i 0 (concatD [doc (showString "_")]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Atom where + prt i e = case e of + AC cident -> prPrec i 0 (concatD [prt 0 cident]) + AD cident -> prPrec i 0 (concatD [doc (showString "<") , prt 0 cident , doc (showString ">")]) + AV id -> prPrec i 0 (concatD [doc (showString "$") , prt 0 id]) + AM n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n]) + AS str -> prPrec i 0 (concatD [prt 0 str]) + AI n -> prPrec i 0 (concatD [prt 0 n]) + AT sort -> prPrec i 0 (concatD [prt 0 sort]) + + +instance Print Decl where + prt i e = case e of + Decl id exp -> prPrec i 0 (concatD [prt 0 id , doc (showString ":") , prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print CType where + prt i e = case e of + RecType labellings -> prPrec i 0 (concatD [doc (showString "{") , prt 0 labellings , doc (showString "}")]) + Table ctype0 ctype -> prPrec i 0 (concatD [doc (showString "(") , prt 0 ctype0 , doc (showString "=>") , prt 0 ctype , doc (showString ")")]) + Cn cident -> prPrec i 0 (concatD [prt 0 cident]) + TStr -> prPrec i 0 (concatD [docs (showString "Str")]) + TInts n -> prPrec i 0 (concatD [docs (showString "Ints") , prt 0 n]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Labelling where + prt i e = case e of + Lbg label ctype -> prPrec i 0 (concatD [prt 0 label , doc (showString ":") , prt 0 ctype]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Term where + prt i e = case e of + Arg argvar -> prPrec i 2 (concatD [prt 0 argvar]) + I cident -> prPrec i 2 (concatD [prt 0 cident]) + Par cident terms -> prPrec i 2 (concatD [doc (showString "<") , prt 0 cident , prt 2 terms , doc (showString ">")]) + LI id -> prPrec i 2 (concatD [doc (showString "$") , prt 0 id]) + R assigns -> prPrec i 2 (concatD [doc (showString "{") , prt 0 assigns , doc (showString "}")]) + P term label -> prPrec i 1 (concatD [prt 2 term , doc (showString ".") , prt 0 label]) + T ctype cases -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "{") , prt 0 cases , doc (showString "}")]) + V ctype terms -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "[") , prt 2 terms , doc (showString "]")]) + S term0 term -> prPrec i 1 (concatD [prt 1 term0 , doc (showString "!") , prt 2 term]) + C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term]) + FV terms -> prPrec i 1 (concatD [docs (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")]) + EInt n -> prPrec i 2 (concatD [prt 0 n]) + EFloat n -> prPrec i 2 (concatD [prt 0 n]) + K tokn -> prPrec i 2 (concatD [prt 0 tokn]) + E -> prPrec i 2 (concatD [doc (showString "[") , doc (showString "]")]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 2 x , prt 2 xs]) + +instance Print Tokn where + prt i e = case e of + KS str -> prPrec i 0 (concatD [prt 0 str]) + KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , docs (showString "pre") , prt 0 strs , doc (showString "{") , prt 0 variants , doc (showString "}") , doc (showString "]")]) + KM str -> prPrec i 0 (concatD [prt 0 str]) + + +instance Print Assign where + prt i e = case e of + Ass label term -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 term]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Case where + prt i e = case e of + Cas patts term -> prPrec i 0 (concatD [prt 0 patts , doc (showString "=>") , prt 0 term]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Variant where + prt i e = case e of + Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Label where + prt i e = case e of + L id -> prPrec i 0 (concatD [prt 0 id]) + LV n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n]) + + +instance Print ArgVar where + prt i e = case e of + A id n -> prPrec i 0 (concatD [prt 0 id , doc (showString "@") , prt 0 n]) + AB id n0 n -> prPrec i 0 (concatD [prt 0 id , doc (showString "+") , prt 0 n0 , doc (showString "@") , prt 0 n]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Patt where + prt i e = case e of + PC cident patts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 patts , doc (showString ")")]) + PV id -> prPrec i 0 (concatD [prt 0 id]) + PW -> prPrec i 0 (concatD [docs (showString "_")]) + PR pattassigns -> prPrec i 0 (concatD [doc (showString "{") , prt 0 pattassigns , doc (showString "}")]) + PI n -> prPrec i 0 (concatD [prt 0 n]) + PF n -> prPrec i 0 (concatD [prt 0 n]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print PattAssign where + prt i e = case e of + PAss label patt -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 patt]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + + diff --git a/src-3.0/GF/Canon/Share.hs b/src-3.0/GF/Canon/Share.hs new file mode 100644 index 000000000..69725001a --- /dev/null +++ b/src-3.0/GF/Canon/Share.hs @@ -0,0 +1,147 @@ +---------------------------------------------------------------------- +-- | +-- Module : Share +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:18 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.12 $ +-- +-- Optimizations on GFC code: sharing, parametrization, value sets. +-- +-- optimization: sharing branches in tables. AR 25\/4\/2003. +-- following advice of Josef Svenningsson +----------------------------------------------------------------------------- + +module GF.Canon.Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where + +import GF.Canon.AbsGFC +import GF.Infra.Ident +import GF.Canon.GFC +import qualified GF.Canon.CMacros as C +import GF.Grammar.PrGrammar (prt) +import GF.Data.Operations +import Data.List +import qualified GF.Infra.Modules as M + +type OptSpec = [Integer] --- + +doOptFactor opt = elem 2 opt +doOptValues opt = elem 3 opt + +shareOpt :: OptSpec +shareOpt = [] + +paramOpt :: OptSpec +paramOpt = [2] + +valOpt :: OptSpec +valOpt = [3] + +allOpt :: OptSpec +allOpt = [2,3] + +shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo) +shareModule opt (i,m) = case m of + M.ModMod (M.Module mt st fs me ops js) -> + (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) + _ -> (i,m) + +shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m) +shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m) +shareInfo _ i = i + +-- | the function putting together optimizations +shareOptim :: OptSpec -> Ident -> Term -> Term +shareOptim opt c + | doOptFactor opt && doOptValues opt = values . factor c 0 + | doOptFactor opt = share . factor c 0 + | doOptValues opt = values + | otherwise = share + +-- | we need no counter to create new variable names, since variables are +-- local to tables +share :: Term -> Term +share t = case t of + T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant. + R lts -> R [Ass l (share t) | Ass l t <- lts] + P t l -> P (share t) l + S t a -> S (share t) (share a) + C t a -> C (share t) (share a) + FV ts -> FV (map share ts) + + _ -> t -- including D, which is always born shared + + where + shareT ty = finalize ty . groupC . sortC + + sortC :: [(Patt,Term)] -> [(Patt,Term)] + sortC = sortBy $ \a b -> compare (snd a) (snd b) + + groupC :: [(Patt,Term)] -> [[(Patt,Term)]] + groupC = groupBy $ \a b -> snd a == snd b + + finalize :: CType -> [[(Patt,Term)]] -> Term + finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css] + + +-- | do even more: factor parametric branches +factor :: Ident -> Int -> Term -> Term +factor c i t = case t of + T _ [_] -> t + T _ [] -> t + T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps] + R lts -> R [Ass l (factor c i t) | Ass l t <- lts] + P t l -> P (factor c i t) l + S t a -> S (factor c i t) (factor c i a) + C t a -> C (factor c i t) (factor c i a) + FV ts -> FV (map (factor c i) ts) + + _ -> t + where + + factors i psvs = -- we know psvs has at least 2 elements + let p = pIdent c i + vs' = map (mkFun p) psvs + in if allEqs vs' + then mkCase p vs' + else psvs + + mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val + + allEqs (v:vs) = all (==v) vs + + mkCase p (v:_) = [Cas [PV p] v] + +pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i) + + +-- | we need to replace subterms +replace :: Term -> Term -> Term -> Term +replace old new trm = case trm of + T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs] + P t l -> P (repl t) l + S t a -> S (repl t) (repl a) + C t a -> C (repl t) (repl a) + FV ts -> FV (map repl ts) + + -- these are the important cases, since they can correspond to patterns + Par c ts | trm == old -> new + Par c ts -> Par c (map repl ts) + R _ | isRec && trm == old -> new + R lts -> R [Ass l (repl t) | Ass l t <- lts] + + _ -> trm + where + repl = replace old new + isRec = case trm of + R _ -> True + _ -> False + +values :: Term -> Term +values t = case t of + T ty [c] -> T ty [Cas p (values t) | Cas p t <- [c]] -- preserve parametrization + T ty cs -> V ty [values t | Cas _ t <- cs] -- assumes proper order + _ -> C.composSafeOp values t diff --git a/src-3.0/GF/Canon/SkelGFC.hs b/src-3.0/GF/Canon/SkelGFC.hs new file mode 100644 index 000000000..a1d9331d8 --- /dev/null +++ b/src-3.0/GF/Canon/SkelGFC.hs @@ -0,0 +1,217 @@ +module GF.Canon.SkelGFC where + +-- Haskell module generated by the BNF converter + +import GF.Canon.AbsGFC +import GF.Data.ErrM +import GF.Infra.Ident + +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Result +transIdent x = case x of + Ident str -> failure x + + +transCanon :: Canon -> Result +transCanon x = case x of + MGr ids id modules -> failure x + Gr modules -> failure x + + +transLine :: Line -> Result +transLine x = case x of + LMulti ids id -> failure x + LHeader modtype extend open -> failure x + LFlag flag -> failure x + LDef def -> failure x + LEnd -> failure x + + +transModule :: Module -> Result +transModule x = case x of + Mod modtype extend open flags defs -> failure x + + +transModType :: ModType -> Result +transModType x = case x of + MTAbs id -> failure x + MTCnc id0 id -> failure x + MTRes id -> failure x + MTTrans id0 id1 id -> failure x + + +transExtend :: Extend -> Result +transExtend x = case x of + Ext ids -> failure x + NoExt -> failure x + + +transOpen :: Open -> Result +transOpen x = case x of + Opens ids -> failure x + NoOpens -> failure x + + +transFlag :: Flag -> Result +transFlag x = case x of + Flg id0 id -> failure x + + +transDef :: Def -> Result +transDef x = case x of + AbsDCat id decls cidents -> failure x + AbsDFun id exp0 exp -> failure x + AbsDTrans id exp -> failure x + ResDPar id pardefs -> failure x + ResDOper id ctype term -> failure x + CncDCat id ctype term0 term -> failure x + CncDFun id cident argvars term0 term -> failure x + AnyDInd id0 status id -> failure x + + +transParDef :: ParDef -> Result +transParDef x = case x of + ParD id ctypes -> failure x + + +transStatus :: Status -> Result +transStatus x = case x of + Canon -> failure x + NonCan -> failure x + + +transCIdent :: CIdent -> Result +transCIdent x = case x of + CIQ id0 id -> failure x + + +transExp :: Exp -> Result +transExp x = case x of + EApp exp0 exp -> failure x + EProd id exp0 exp -> failure x + EAbs id exp -> failure x + EAtom atom -> failure x + EData -> failure x + EEq equations -> failure x + + +transSort :: Sort -> Result +transSort x = case x of + SType -> failure x + + +transEquation :: Equation -> Result +transEquation x = case x of + Equ apatts exp -> failure x + + +transAPatt :: APatt -> Result +transAPatt x = case x of + APC cident apatts -> failure x + APV id -> failure x + APS str -> failure x + API n -> failure x + APW -> failure x + + +transAtom :: Atom -> Result +transAtom x = case x of + AC cident -> failure x + AD cident -> failure x + AV id -> failure x + AM n -> failure x + AS str -> failure x + AI n -> failure x + AT sort -> failure x + + +transDecl :: Decl -> Result +transDecl x = case x of + Decl id exp -> failure x + + +transCType :: CType -> Result +transCType x = case x of + RecType labellings -> failure x + Table ctype0 ctype -> failure x + Cn cident -> failure x + TStr -> failure x + TInts n -> failure x + + +transLabelling :: Labelling -> Result +transLabelling x = case x of + Lbg label ctype -> failure x + + +transTerm :: Term -> Result +transTerm x = case x of + Arg argvar -> failure x + I cident -> failure x + Par cident terms -> failure x + LI id -> failure x + R assigns -> failure x + P term label -> failure x + T ctype cases -> failure x + V ctype terms -> failure x + S term0 term -> failure x + C term0 term -> failure x + FV terms -> failure x + EInt n -> failure x + K tokn -> failure x + E -> failure x + + +transTokn :: Tokn -> Result +transTokn x = case x of + KS str -> failure x + KP strs variants -> failure x + KM str -> failure x + + +transAssign :: Assign -> Result +transAssign x = case x of + Ass label term -> failure x + + +transCase :: Case -> Result +transCase x = case x of + Cas patts term -> failure x + + +transVariant :: Variant -> Result +transVariant x = case x of + Var strs0 strs -> failure x + + +transLabel :: Label -> Result +transLabel x = case x of + L id -> failure x + LV n -> failure x + + +transArgVar :: ArgVar -> Result +transArgVar x = case x of + A id n -> failure x + AB id n0 n -> failure x + + +transPatt :: Patt -> Result +transPatt x = case x of + PC cident patts -> failure x + PV id -> failure x + PW -> failure x + PR pattassigns -> failure x + PI n -> failure x + + +transPattAssign :: PattAssign -> Result +transPattAssign x = case x of + PAss label patt -> failure x + + + diff --git a/src-3.0/GF/Canon/Subexpressions.hs b/src-3.0/GF/Canon/Subexpressions.hs new file mode 100644 index 000000000..683f9eecf --- /dev/null +++ b/src-3.0/GF/Canon/Subexpressions.hs @@ -0,0 +1,170 @@ +---------------------------------------------------------------------- +-- | +-- Module : Subexpressions +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/20 09:32:56 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.4 $ +-- +-- Common subexpression elimination. +-- all tables. AR 18\/9\/2005. +----------------------------------------------------------------------------- + +module GF.Canon.Subexpressions ( + elimSubtermsMod, prSubtermStat, unSubelimCanon, unSubelimModule + ) where + +import GF.Canon.AbsGFC +import GF.Infra.Ident +import GF.Canon.GFC +import GF.Canon.Look +import GF.Grammar.PrGrammar +import GF.Canon.CMacros as C +import GF.Data.Operations +import qualified GF.Infra.Modules as M + +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List + +{- +This module implements a simple common subexpression elimination + for gfc grammars, to factor out shared subterms in lin rules. +It works in three phases: + + (1) collectSubterms collects recursively all subterms of forms table and (P x..y) + from lin definitions (experience shows that only these forms + tend to get shared) and counts how many times they occur + (2) addSubexpConsts takes those subterms t that occur more than once + and creates definitions of form "oper A''n = t" where n is a + fresh number; notice that we assume no ids of this form are in + scope otherwise + (3) elimSubtermsMod goes through lins and the created opers by replacing largest + possible subterms by the newly created identifiers + +The optimization is invoked in gf by the flag i -subs. + +If an application does not support GFC opers, the effect of this +optimization can be undone by the function unSubelimCanon. + +The function unSubelimCanon can be used to diagnostisize how much +cse is possible in the grammar. It is used by the flag pg -printer=subs. + +-} + +-- exported functions + +elimSubtermsMod :: (Ident,CanonModInfo) -> Err (Ident, CanonModInfo) +elimSubtermsMod (mo,m) = case m of + M.ModMod (M.Module mt st fs me ops js) -> do + (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) + js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js + return (mo,M.ModMod (M.Module mt st fs me ops js2)) + _ -> return (mo,m) + +prSubtermStat :: CanonGrammar -> String +prSubtermStat gr = unlines [prt mo ++++ expsIn mo js | (mo,js) <- mos] where + mos = [(i, tree2list (M.jments m)) | (i, M.ModMod m) <- M.modules gr, M.isModCnc m] + expsIn mo js = err id id $ do + (tree,_) <- appSTM (getSubtermsMod mo js) (Map.empty,0) + let list0 = Map.toList tree + let list1 = sortBy (\ (_,(m,_)) (_,(n,_)) -> compare n m) list0 + return $ unlines [show n ++ "\t" ++ prt trm | (trm,(n,_)) <- list1] + +unSubelimCanon :: CanonGrammar -> CanonGrammar +unSubelimCanon gr@(M.MGrammar modules) = + M.MGrammar $ map unSubelimModule modules + +unSubelimModule :: CanonModule -> CanonModule +unSubelimModule mo@(i,m) = case m of + M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) | hasSub ljs -> + (i, M.ModMod (M.Module mt st fs me ops + (rebuild (map unparInfo ljs)))) + where ljs = tree2list js + _ -> (i,m) + where + -- perform this iff the module has opers + hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] + unparInfo (c,info) = case info of + CncFun k xs t m -> [(c, CncFun k xs (unparTerm t) m)] + ResOper _ _ -> [] + _ -> [(c,info)] + unparTerm t = case t of + I c -> errVal t $ liftM unparTerm $ lookupGlobal gr c + _ -> C.composSafeOp unparTerm t + gr = M.MGrammar [mo] + rebuild = buildTree . concat + +-- implementation + +type TermList = Map Term (Int,Int) -- number of occs, id +type TermM a = STM (TermList,Int) a + +addSubexpConsts :: Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] +addSubexpConsts mo tree lins = do + let opers = [oper id trm | (trm,(_,id)) <- list] + mapM mkOne $ opers ++ lins + where + + mkOne (f,def) = case def of + CncFun ci xs trm pn -> do + trm' <- recomp f trm + return (f,CncFun ci xs trm' pn) + ResOper ty trm -> do + trm' <- recomp f trm + return (f,ResOper ty trm') + _ -> return (f,def) + recomp f t = case Map.lookup t tree of + Just (_,id) | ident id /= f -> return $ I $ cident mo id + _ -> composOp (recomp f) t + + list = Map.toList tree + + oper id trm = (ident id, ResOper TStr trm) --- type TStr does not matter + +getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) +getSubtermsMod mo js = do + mapM (getInfo (collectSubterms mo)) js + (tree0,_) <- readSTM + return $ Map.filter (\ (nu,_) -> nu > 1) tree0 + where + getInfo get fi@(f,i) = case i of + CncFun ci xs trm pn -> do + get trm + return $ fi + ResOper ty trm -> do + get trm + return $ fi + _ -> return fi + +collectSubterms :: Ident -> Term -> TermM Term +collectSubterms mo t = case t of + Par _ (_:_) -> add t + T ty cs -> do + let (ps,ts) = unzip [(p,t) | Cas p t <- cs] + mapM (collectSubterms mo) ts + add t + V ty ts -> do + mapM (collectSubterms mo) ts + add t + K (KP _ _) -> add t + _ -> composOp (collectSubterms mo) t + where + add t = do + (ts,i) <- readSTM + let + ((count,id),next) = case Map.lookup t ts of + Just (nu,id) -> ((nu+1,id), i) + _ -> ((1, i ), i+1) + writeSTM (Map.insert t (count,id) ts, next) + return t --- only because of composOp + +ident :: Int -> Ident +ident i = identC ("A''" ++ show i) --- + +cident :: Ident -> Int -> CIdent +cident mo = CIQ mo . ident diff --git a/src-3.0/GF/Canon/TestGFC.hs b/src-3.0/GF/Canon/TestGFC.hs new file mode 100644 index 000000000..7c89d64e8 --- /dev/null +++ b/src-3.0/GF/Canon/TestGFC.hs @@ -0,0 +1,58 @@ +-- automatically generated by BNF Converter +module Main where + + +import IO ( stdin, hGetContents ) +import System ( getArgs, getProgName ) + +import GF.Canon.LexGFC +import GF.Canon.ParGFC +import GF.Canon.SkelGFC +import GF.Canon.PrintGFC +import GF.Canon.AbsGFC +import GF.Infra.Ident + + + +import GF.Data.ErrM + +type ParseFun a = [Token] -> Err a + +myLLexer = myLexer + +type Verbosity = Int + +putStrV :: Verbosity -> String -> IO () +putStrV v s = if v > 1 then putStrLn s else return () + +runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () +runFile v p f = putStrLn f >> readFile f >>= run v p + +run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () +run v p s = let ts = myLLexer s in case p ts of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrV v "Tokens:" + putStrV v $ show ts + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + showTree v tree + + + +showTree :: (Show a, Print a) => Int -> a -> IO () +showTree v tree + = do + putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree + +main :: IO () +main = do args <- getArgs + case args of + [] -> hGetContents stdin >>= run 2 pCanon + "-s":fs -> mapM_ (runFile 0 pCanon) fs + fs -> mapM_ (runFile 2 pCanon) fs + + + + + diff --git a/src-3.0/GF/Canon/Unlex.hs b/src-3.0/GF/Canon/Unlex.hs new file mode 100644 index 000000000..dd93390e2 --- /dev/null +++ b/src-3.0/GF/Canon/Unlex.hs @@ -0,0 +1,49 @@ +---------------------------------------------------------------------- +-- | +-- Module : Unlex +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:32 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- elementary text postprocessing. AR 21/11/2001 +----------------------------------------------------------------------------- + +module GF.Canon.Unlex (formatAsText, unlex, performBinds) where + +import GF.Data.Operations +import GF.Data.Str + +import Data.Char +import Data.List (isPrefixOf) + +formatAsText :: String -> String +formatAsText = unwords . format . cap . words where + format ws = case ws of + w : c : ww | major c -> (w ++ c) : format (cap ww) + w : c : ww | minor c -> (w ++ c) : format ww + c : ww | para c -> "\n\n" : format ww + w : ww -> w : format ww + [] -> [] + cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww + cap ((c:cs):ww) = (toUpper c : cs) : ww + cap [] = [] + major = flip elem (map (:[]) ".!?") + minor = flip elem (map (:[]) ",:;") + para = (=="&-") + +unlex :: [Str] -> String +unlex = formatAsText . performBinds . concat . map sstr . take 1 ---- + +-- | modified from GF/src/Text by adding hyphen +performBinds :: String -> String +performBinds = unwords . format . words where + format ws = case ws of + w : "-" : u : ws -> format ((w ++ "-" ++ u) : ws) + w : "&+" : u : ws -> format ((w ++ u) : ws) + w : ws -> w : format ws + [] -> [] + diff --git a/src-3.0/GF/Canon/Unparametrize.hs b/src-3.0/GF/Canon/Unparametrize.hs new file mode 100644 index 000000000..0ca6a2d9c --- /dev/null +++ b/src-3.0/GF/Canon/Unparametrize.hs @@ -0,0 +1,63 @@ +---------------------------------------------------------------------- +-- | +-- Module : Unparametrize +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/14 16:26:21 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.1 $ +-- +-- Taking away parameters from a canonical grammar. All param +-- types are replaced by {}, and only one branch is left in +-- all tables. AR 14\/9\/2005. +----------------------------------------------------------------------------- + +module GF.Canon.Unparametrize (unparametrizeCanon) where + +import GF.Canon.AbsGFC +import GF.Infra.Ident +import GF.Canon.GFC +import qualified GF.Canon.CMacros as C +import GF.Data.Operations +import qualified GF.Infra.Modules as M + +unparametrizeCanon :: CanonGrammar -> CanonGrammar +unparametrizeCanon (M.MGrammar modules) = + M.MGrammar $ map unparModule modules where + + unparModule (i,m) = case m of + M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) -> + let me' = [(unparIdent j,incl) | (j,incl) <- me] in + (unparIdent i, M.ModMod (M.Module mt st fs me' ops (mapTree unparInfo js))) + _ -> (i,m) + + unparInfo (c,info) = case info of + CncCat ty t m -> (c, CncCat (unparCType ty) (unparTerm t) m) + CncFun k xs t m -> (c, CncFun k xs (unparTerm t) m) + AnyInd b i -> (c, AnyInd b (unparIdent i)) + _ -> (c,info) + + unparCType ty = case ty of + RecType ls -> RecType [Lbg lab (unparCType t) | Lbg lab t <- ls] + Table _ v -> unparCType v --- Table unitType (unparCType v) + Cn _ -> unitType + _ -> ty + + unparTerm t = case t of + Par _ _ -> unitTerm + T _ cs -> unparTerm (head [t | Cas _ t <- cs]) + V _ ts -> unparTerm (head ts) + S t _ -> unparTerm t +{- + T _ cs -> V unitType [unparTerm (head [t | Cas _ t <- cs])] + V _ ts -> V unitType [unparTerm (head ts)] + S t _ -> S (unparTerm t) unitTerm +-} + _ -> C.composSafeOp unparTerm t + + unitType = RecType [] + unitTerm = R [] + + unparIdent (IC s) = IC $ "UP_" ++ s diff --git a/src-3.0/GF/Canon/log.txt b/src-3.0/GF/Canon/log.txt new file mode 100644 index 000000000..44dba3954 --- /dev/null +++ b/src-3.0/GF/Canon/log.txt @@ -0,0 +1,20 @@ +GFCC, 6/9/2006 + +66661 24 Par remaining to be sent to GFC +66662 0 not covered by mkTerm +66663 36 label not in numeric format in mkTerm +66664 2 label not found in symbol table +66665 36 projection from deeper than just arg var: NP.agr.n +66667 0 parameter value not found in symbol table +66668 1 variable in parameter argument + + + +66664 2 +66665 125 missing: (VP.s!vf).fin +66668 1 + + +66661/3 24 same lines: +66664 2 +66668 1 diff --git a/src-3.0/GF/Command/AbsGFShell.hs b/src-3.0/GF/Command/AbsGFShell.hs new file mode 100644 index 000000000..c13004cf9 --- /dev/null +++ b/src-3.0/GF/Command/AbsGFShell.hs @@ -0,0 +1,42 @@ +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-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs new file mode 100644 index 000000000..d5b5a8768 --- /dev/null +++ b/src-3.0/GF/Command/Commands.hs @@ -0,0 +1,159 @@ +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-3.0/GF/Command/GFShell.cf b/src-3.0/GF/Command/GFShell.cf new file mode 100644 index 000000000..1f5a9fa6d --- /dev/null +++ b/src-3.0/GF/Command/GFShell.cf @@ -0,0 +1,27 @@ +--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-3.0/GF/Command/Importing.hs b/src-3.0/GF/Command/Importing.hs new file mode 100644 index 000000000..a09ba8de6 --- /dev/null +++ b/src-3.0/GF/Command/Importing.hs @@ -0,0 +1,28 @@ +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-3.0/GF/Command/Interpreter.hs b/src-3.0/GF/Command/Interpreter.hs new file mode 100644 index 000000000..10730e7ef --- /dev/null +++ b/src-3.0/GF/Command/Interpreter.hs @@ -0,0 +1,74 @@ +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-3.0/GF/Command/LexGFShell.hs b/src-3.0/GF/Command/LexGFShell.hs new file mode 100644 index 000000000..8e0191039 --- /dev/null +++ b/src-3.0/GF/Command/LexGFShell.hs @@ -0,0 +1,337 @@ +{-# 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-3.0/GF/Command/PPrTree.hs b/src-3.0/GF/Command/PPrTree.hs new file mode 100644 index 000000000..7372c722d --- /dev/null +++ b/src-3.0/GF/Command/PPrTree.hs @@ -0,0 +1,39 @@ +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-3.0/GF/Command/ParGFShell.hs b/src-3.0/GF/Command/ParGFShell.hs new file mode 100644 index 000000000..1fc85b4b7 --- /dev/null +++ b/src-3.0/GF/Command/ParGFShell.hs @@ -0,0 +1,809 @@ +{-# 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-3.0/GF/Command/PrintGFShell.hs b/src-3.0/GF/Command/PrintGFShell.hs new file mode 100644 index 000000000..31a4584b6 --- /dev/null +++ b/src-3.0/GF/Command/PrintGFShell.hs @@ -0,0 +1,144 @@ +{-# 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-3.0/GF/Compile/API.hs b/src-3.0/GF/Compile/API.hs new file mode 100644 index 000000000..242a9e87a --- /dev/null +++ b/src-3.0/GF/Compile/API.hs @@ -0,0 +1,21 @@ +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-3.0/GF/Compile/BackOpt.hs b/src-3.0/GF/Compile/BackOpt.hs new file mode 100644 index 000000000..8356f2ba2 --- /dev/null +++ b/src-3.0/GF/Compile/BackOpt.hs @@ -0,0 +1,141 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs new file mode 100644 index 000000000..b33d11017 --- /dev/null +++ b/src-3.0/GF/Compile/CheckGrammar.hs @@ -0,0 +1,1078 @@ +---------------------------------------------------------------------- +-- | +-- Module : CheckGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.31 $ +-- +-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 +-- +-- type checking also does the following modifications: +-- +-- - types of operations and local constants are inferred and put in place +-- +-- - both these types and linearization types are computed +-- +-- - tables are type-annotated +----------------------------------------------------------------------------- + +module GF.Compile.CheckGrammar ( + showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Grammar.Refresh ---- + +import GF.Grammar.TypeCheck +import GF.Grammar.Values (cPredefAbs) --- + +import GF.Grammar.PrGrammar +import GF.Grammar.Lookup +import GF.Grammar.LookAbs +import GF.Grammar.Macros +import GF.Grammar.ReservedWords ---- +import GF.Grammar.PatternMatch +import GF.Grammar.AppPredefined +import GF.Grammar.Lockfield (isLockLabel) + +import GF.Data.Operations +import GF.Infra.CheckM + +import Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Monad +import Debug.Trace --- + + +showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String) +showCheckModule mos m = do + (st,(_,msg)) <- checkStart $ checkModule mos m + return (st, unlines $ reverse msg) + +-- | checking is performed in the dependency order of modules +checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] +checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of + + ModMod mo@(Module mt st fs me ops js) -> do + checkRestrictedInheritance ms (name, mo) + js' <- case mt of + MTAbstract -> mapMTree (checkAbsInfo gr name) js + + MTTransfer a b -> mapMTree (checkAbsInfo gr name) js + + MTResource -> mapMTree (checkResInfo gr name) js + + MTConcrete a -> do + checkErr $ topoSortOpers $ allOperDependencies name js + ModMod abs <- checkErr $ lookupModule gr a + js1 <- checkCompleteGrammar abs mo + mapMTree (checkCncInfo gr name (a,abs)) js1 + + MTInterface -> mapMTree (checkResInfo gr name) js + + MTInstance a -> do + ModMod abs <- checkErr $ lookupModule gr a + -- checkCompleteInstance abs mo -- this is done in Rebuild + mapMTree (checkResInfo gr name) js + + return $ (name, ModMod (Module mt st fs me ops js')) : ms + + _ -> return $ (name,mod) : ms + where + gr = MGrammar $ (name,mod):ms + +-- check if restricted inheritance modules are still coherent +-- i.e. that the defs of remaining names don't depend on omitted names +---checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () +checkRestrictedInheritance mos (name,mo) = do + let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. + let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] + -- the restr. modules themself, with restr. infos + mapM_ checkRem mrs + where + checkRem ((i,m),mi) = do + let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) + let incld c = Set.member c (Set.fromList incl) + let illegal c = Set.member c (Set.fromList excl) + let illegals = [(f,is) | + (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] + case illegals of + [] -> return () + cs -> fail $ "In inherited module" +++ prt i ++ + ", dependence of excluded constants:" ++++ + unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | + (f,is) <- cs] + allDeps = ---- transClosure $ Map.fromList $ + concatMap (allDependencies (const True)) + [jments m | (_,ModMod m) <- mos] + transClosure ds = ds ---- TODO: check in deeper modules + +-- | check if a term is typable +justCheckLTerm :: SourceGrammar -> Term -> Err Term +justCheckLTerm src t = do + ((t',_),_) <- checkStart (inferLType src t) + return t' + +checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) +checkAbsInfo st m (c,info) = do +---- checkReservedId c + case info of + AbsCat (Yes cont) _ -> mkCheck "category" $ + checkContext st cont ---- also cstrs + AbsFun (Yes typ0) md -> do + typ <- compAbsTyp [] typ0 -- to calculate let definitions + mkCheck "type of function" $ checkTyp st typ + md' <- case md of + Yes d -> do + let d' = elimTables d + mkCheckWarn "definition of function" $ checkEquation st (m,c) d' + return $ Yes d' + _ -> return md + return $ (c,AbsFun (Yes typ) md') + _ -> return (c,info) + where + mkCheck cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + ---- temporary solution when tc of defs is incomplete + mkCheckWarn cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) + compAbsTyp g t = case t of + Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g + Let (x,(_,a)) b -> do + a' <- compAbsTyp g a + compAbsTyp ((x, a'):g) b + Prod x a b -> do + a' <- compAbsTyp g a + b' <- compAbsTyp ((x,Vr x):g) b + return $ Prod x a' b' + Abs _ _ -> return t + _ -> composOp (compAbsTyp g) t + + elimTables e = case e of + S t a -> elimSel (elimTables t) (elimTables a) + T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] + _ -> composSafeOp elimTables e + elimPatt p = case p of + PR lps -> map snd lps + _ -> [p] + elimSel t a = case a of + R fs -> mkApp t (map (snd . snd) fs) + _ -> mkApp t [a] + +checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info) +checkCompleteGrammar abs cnc = do + let js = jments cnc + let fs = tree2list $ jments abs + foldM checkOne js fs + where + checkOne js i@(c,info) = case info of + AbsFun (Yes _) _ -> case lookupIdent c js of + Ok _ -> return js + _ -> do + checkWarn $ "WARNING: no linearization of" +++ prt c + return js + AbsCat (Yes _) _ -> case lookupIdent c js of + Ok (AnyInd _ _) -> return js + Ok (CncCat (Yes _) _ _) -> return js + Ok (CncCat _ mt mp) -> do + checkWarn $ + "Warning: no linearization type for" +++ prt c ++ + ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Yes defLinType) mt mp) js + _ -> do + checkWarn $ + "Warning: no linearization type for" +++ prt c ++ + ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Yes defLinType) nope nope) js + _ -> return js + +-- | General Principle: only Yes-values are checked. +-- A May-value has always been checked in its origin module. +checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) +checkResInfo gr mo (c,info) = do + checkReservedId c + case info of + ResOper pty pde -> chIn "operation" $ do + (pty', pde') <- case (pty,pde) of + (Yes ty, Yes de) -> do + ty' <- check ty typeType >>= comp . fst + (de',_) <- check de ty' + return (Yes ty', Yes de') + (_, Yes de) -> do + (de',ty') <- infer de + return (Yes ty', Yes de') + (_,Nope) -> do + checkWarn "No definition given to oper" + return (pty,pde) + _ -> return (pty, pde) --- other cases are uninteresting + return (c, ResOper pty' pde') + + ResOverload tysts -> chIn "overloading" $ do + tysts' <- mapM (uncurry $ flip check) tysts + let tysts2 = [(y,x) | (x,y) <- tysts'] + --- this can only be a partial guarantee, since matching + --- with value type is only possible if expected type is given + checkUniq $ + sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]] + return (c,ResOverload tysts2) + + ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do +---- mapM ((mapM (computeLType gr . snd)) . snd) pcs + mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs + ts <- checkErr $ lookupParamValues gr mo c + return (c,ResParam (Yes (pcs, Just ts))) + + _ -> return (c,info) + where + infer = inferLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + comp = computeLType gr + + checkUniq xss = case xss of + x:y:xs + | x == y -> raise $ "ambiguous for argument list" +++ + unwords (map (prtType gr) x) + | otherwise -> checkUniq $ y:xs + _ -> return () + + +checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> + (Ident,Info) -> Check (Ident,Info) +checkCncInfo gr m (a,abs) (c,info) = do + checkReservedId c + case info of + + CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do + typ <- checkErr $ lookupFunTypeSrc gr a c + cat0 <- checkErr $ valCat typ + (cont,val) <- linTypeOfType gr m typ -- creates arg vars + (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars + checkPrintname gr mpr + cat <- return $ snd cat0 + return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) + -- cat for cf, typ for pe + + CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do + checkErr $ lookupCatContextSrc gr a c + typ' <- checkIfLinType gr typ + mdef' <- case mdef of + Yes def -> do + (def',_) <- checkLType gr def (mkFunType [typeStr] typ) + return $ Yes def' + _ -> return mdef + checkPrintname gr mpr + return (c,CncCat (Yes typ') mdef' mpr) + + _ -> checkResInfo gr m (c,info) + + where + env = gr + infer = inferLType gr + comp = computeLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + +checkIfParType :: SourceGrammar -> Type -> Check () +checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) + where + isParType ty = True ---- +{- case ty of + Cn typ -> case lookupConcrete st typ of + Ok (CncParType _ _ _) -> True + Ok (CncOper _ ty' _) -> isParType ty' + _ -> False + Q p t -> case lookupInPackage st (p,t) of + Ok (CncParType _ _ _) -> True + _ -> False + RecType r -> all (isParType . snd) r + _ -> False +-} + +checkIfStrType :: SourceGrammar -> Type -> Check () +checkIfStrType st typ = case typ of + Table arg val -> do + checkIfParType st arg + checkIfStrType st val + _ | typ == typeStr -> return () + _ -> prtFail "not a string type" typ + + +checkIfLinType :: SourceGrammar -> Type -> Check Type +checkIfLinType st typ0 = do + typ <- computeLType st typ0 + case typ of + RecType r -> do + let (lins,ihs) = partition (isLinLabel .fst) r + --- checkErr $ checkUnique $ map fst r + mapM_ checkInh ihs + mapM_ checkLin lins + _ -> prtFail "a linearization type must be a record type instead of" typ + return typ + + where + checkInh (label,typ) = checkIfParType st typ + checkLin (label,typ) = return () ---- checkIfStrType st typ + + +computeLType :: SourceGrammar -> Type -> Check Type +computeLType gr t = do + g0 <- checkGetContext + let g = [(x, Vr x) | (x,_) <- g0] + checkInContext g $ comp t + where + comp ty = case ty of + + App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed + Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed + Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed + Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed + + Q m c | elem c [cPredef,cPredefAbs] -> return ty + Q m c | elem c [zIdent "Int"] -> + return $ linTypeInt + Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ---- + + Q m ident -> checkIn ("module" +++ prt m) $ do + ty' <- checkErr (lookupResDef gr m ident) + if ty' == ty then return ty else comp ty' --- is this necessary to test? + + Vr ident -> checkLookup ident -- never needed to compute! + + App f a -> do + f' <- comp f + a' <- comp a + case f' of + Abs x b -> checkInContext [(x,a')] $ comp b + _ -> return $ App f' a' + + Prod x a b -> do + a' <- comp a + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Prod x a' b' + + Abs x b -> do + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Abs x b' + + ExtR r s -> do + r' <- comp r + s' <- comp s + case (r',s') of + (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp + _ -> return $ ExtR r' s' + + RecType fs -> do + let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs + liftM RecType $ mapPairsM comp fs' + + _ | ty == typeTok -> return typeStr + _ | isPredefConstant ty -> return ty + + _ -> composOp comp ty + +checkPrintname :: SourceGrammar -> Perh Term -> Check () +checkPrintname st (Yes t) = checkLType st t typeStr >> return () +checkPrintname _ _ = return () + +-- | for grammars obtained otherwise than by parsing ---- update!! +checkReservedId :: Ident -> Check () +checkReservedId x = let c = prt x in + if isResWord c + then checkWarn ("Warning: reserved word used as identifier:" +++ c) + else return () + +-- to normalize records and record types +labelIndex :: Type -> Label -> Int +labelIndex ty lab = case ty of + RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts + _ -> error $ "label index" +++ prt ty + where + labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] + +-- the underlying algorithms + +inferLType :: SourceGrammar -> Term -> Check (Term, Type) +inferLType gr trm = case trm of + + Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + Q m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) >>= comp + , + checkErr (lookupResDef gr m ident) >>= infer + , +{- + do + over <- getOverload gr Nothing trm + case over of + Just trty -> return trty + _ -> prtFail "not overloaded" trm + , +-} + prtFail "cannot infer type of constant" trm + ] + + QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + QC m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) >>= comp + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of canonical constant" trm + ] + + Val ty i -> termWith trm $ return ty + + Vr ident -> termWith trm $ checkLookup ident + + Typed e t -> do + t' <- comp t + check e t' + return (e,t') + + App f a -> do + over <- getOverload gr Nothing trm + case over of + Just trty -> return trty + _ -> do + (f',fty) <- infer f + fty' <- comp fty + case fty' of + Prod z arg val -> do + a' <- justCheck a arg + ty <- if isWildIdent z + then return val + else substituteLType [(z,a')] val + return (App f' a',ty) + _ -> raise ("function type expected for"+++ + prt f +++"instead of" +++ prtType env fty) + + S f x -> do + (f', fty) <- infer f + case fty of + Table arg val -> do + x'<- justCheck x arg + return (S f' x', val) + _ -> prtFail "table lintype expected for the table in" trm + + P t i -> do + (t',ty) <- infer t --- ?? + ty' <- comp ty +----- let tr2 = PI t' i (labelIndex ty' i) + let tr2 = P t' i + termWith tr2 $ checkErr $ case ty' of + RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ + lookup i ts + _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' + PI t i _ -> infer $ P t i + + R r -> do + let (ls,fs) = unzip r + fsts <- mapM inferM fs + let ts = [ty | (Just ty,_) <- fsts] + checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) + return $ (R (zip ls fsts), RecType (zip ls ts)) + + T (TTyped arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T (TComp arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T ti pts -> do -- tries to guess: good in oper type inference + let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] + case pts' of + [] -> prtFail "cannot infer table type of" trm +---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] + _ -> do + (arg,val) <- checks $ map (inferCase Nothing) pts' + check trm (Table arg val) + V arg pts -> do + (_,val) <- checks $ map infer pts + return (trm, Table arg val) + + K s -> do + if elem ' ' s + then checkWarn ("WARNING: space in token \"" ++ s ++ + "\". Lexical analysis may fail.") + else return () + return (trm, typeStr) + + EInt i -> return (trm, typeInt) + + EFloat i -> return (trm, typeFloat) + + Empty -> return (trm, typeStr) + + C s1 s2 -> + check2 (flip justCheck typeStr) C s1 s2 typeStr + + Glue s1 s2 -> + check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok + +---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 + Strs (Cn (IC "#conflict") : ts) -> do + trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) +-- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) +-- infer $ head ts + + Strs ts -> do + ts' <- mapM (\t -> justCheck t typeStr) ts + return (Strs ts', typeStrs) + + Alts (t,aa) -> do + t' <- justCheck t typeStr + aa' <- flip mapM aa (\ (c,v) -> do + c' <- justCheck c typeStr + v' <- justCheck v typeStrs + return (c',v')) + return (Alts (t',aa'), typeStr) + + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM (flip justCheck typeType) ts + return (RecType (zip ls ts'), typeType) + + ExtR r s -> do + (r',rT) <- infer r + rT' <- comp rT + (s',sT) <- infer s + sT' <- comp sT + + let trm' = ExtR r' s' + ---- trm' <- checkErr $ plusRecord r' s' + case (rT', sT') of + (RecType rs, RecType ss) -> do + rt <- checkErr $ plusRecType rT' sT' + check trm' rt ---- return (trm', rt) + _ | rT' == typeType && sT' == typeType -> return (trm', typeType) + _ -> prtFail "records or record types expected in" trm + + Sort _ -> + termWith trm $ return typeType + + Prod x a b -> do + a' <- justCheck a typeType + b' <- checkInContext [(x,a')] $ justCheck b typeType + return (Prod x a' b', typeType) + + Table p t -> do + p' <- justCheck p typeType --- check p partype! + t' <- justCheck t typeType + return $ (Table p' t', typeType) + + FV vs -> do + (_,ty) <- checks $ map infer vs +--- checkIfComplexVariantType trm ty + check trm ty + + _ -> prtFail "cannot infer lintype of" trm + + where + env = gr + infer = inferLType env + comp = computeLType env + + check = checkLType env + + isPredef m = elem m [cPredef,cPredefAbs] + + justCheck ty te = check ty te >>= return . fst + + -- for record fields, which may be typed + inferM (mty, t) = do + (t', ty') <- case mty of + Just ty -> check ty t + _ -> infer t + return (Just ty',t') + + inferCase mty (patt,term) = do + arg <- maybe (inferPatt patt) return mty + cont <- pattContext env arg patt + i <- checkUpdates cont + (_,val) <- infer term + checkResets i + return (arg,val) + isConstPatt p = case p of + PC _ ps -> True --- all isConstPatt ps + PP _ _ ps -> True --- all isConstPatt ps + PR ps -> all (isConstPatt . snd) ps + PT _ p -> isConstPatt p + PString _ -> True + PInt _ -> True + PFloat _ -> True + PChar -> True + PSeq p q -> isConstPatt p && isConstPatt q + PAlt p q -> isConstPatt p && isConstPatt q + PRep p -> isConstPatt p + PNeg p -> isConstPatt p + PAs _ p -> isConstPatt p + _ -> False + + inferPatt p = case p of + PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc + PAs _ p -> inferPatt p + PNeg p -> inferPatt p + PAlt p q -> checks [inferPatt p, inferPatt q] + PSeq _ _ -> return $ typeStr + PChar -> return $ typeStr + PRep _ -> return $ typeStr + _ -> infer (patt2term p) >>= return . snd + + +-- type inference: Nothing, type checking: Just t +-- the latter permits matching with value type +getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type)) +getOverload env@gr mt t = case appForm t of + (f@(Q m c), ts) -> case lookupOverload gr m c of + Ok typs -> do + ttys <- mapM infer ts + v <- matchOverload f typs ttys + return $ Just v + _ -> return Nothing + _ -> return Nothing + where + infer = inferLType env + matchOverload f typs ttys = do + let (tts,tys) = unzip ttys + let vfs = lookupOverloadInstance tys typs + + case [vf | vf@(v,f) <- vfs, matchVal mt v] of + [(val,fun)] -> return (mkApp fun tts, val) + [] -> raise $ "no overload instance of" +++ prt f +++ + "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ + unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ + maybe [] (("with value type" +++) . prtType env) mt + + ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" + ---- ++++ unlines (map (show . fst) typs) ---- + + vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of + [(val,fun)] -> do + checkWarn $ "WARNING: overloading of" +++ prt f +++ + "resolved by excluding partial applications:" ++++ + unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] + return (mkApp fun tts, val) + + _ -> raise $ "ambiguous overloading of" +++ prt f +++ + "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ + unlines [prtType env ty | (ty,_) <- vfs'] + + matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where + unlocked = case v of + RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs] + _ -> [] + ---- TODO: accept subtypes + ---- TODO: use a trie + lookupOverloadInstance tys typs = + [(mkFunType rest val, t) | + let lt = length tys, + (ty,(val,t)) <- typs, length ty >= lt, + let (pre,rest) = splitAt lt ty, + pre == tys + ] + + noProd ty = case ty of + Prod _ _ _ -> False + _ -> True + +checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) +checkLType env trm typ0 = do + + typ <- comp typ0 + + case trm of + + Abs x c -> do + case typ of + Prod z a b -> do + checkUpdate (x,a) + (c',b') <- if isWildIdent z + then check c b + else do + b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b + check c b' + checkReset + return $ (Abs x c', Prod x a b') + _ -> raise $ "product expected instead of" +++ prtType env typ + + App f a -> do + over <- getOverload env (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + + Q _ _ -> do + over <- getOverload env (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + + T _ [] -> + prtFail "found empty table in type" typ + T _ cs -> case typ of + Table arg val -> do + case allParamValues env arg of + Ok vs -> do + let ps0 = map fst cs + ps <- checkErr $ testOvershadow ps0 vs + if null ps + then return () + else checkWarn $ "WARNING: patterns never reached:" +++ + concat (intersperse ", " (map prt ps)) + + _ -> return () -- happens with variable types + cs' <- mapM (checkCase arg val) cs + return (T (TTyped arg) cs', typ) + _ -> raise $ "table type expected for table instead of" +++ prtType env typ + + R r -> case typ of --- why needed? because inference may be too difficult + RecType rr -> do + let (ls,_) = unzip rr -- labels of expected type + fsts <- mapM (checkM r) rr -- check that they are found in the record + return $ (R fsts, typ) -- normalize record + + _ -> prtFail "record type expected in type checking instead of" typ + + ExtR r s -> case typ of + _ | typ == typeType -> do + trm' <- comp trm + case trm' of + RecType _ -> termWith trm $ return typeType + ExtR (Vr _) (RecType _) -> termWith trm $ return typeType + -- ext t = t ** ... + _ -> prtFail "invalid record type extension" trm + RecType rr -> do + (r',ty,s') <- checks [ + do (r',ty) <- infer r + return (r',ty,s) + , + do (s',ty) <- infer s + return (s',ty,r) + ] + case ty of + RecType rr1 -> do + let (rr0,rr2) = recParts rr rr1 + r2 <- justCheck r' rr0 + s2 <- justCheck s' rr2 + return $ (ExtR r2 s2, typ) + _ -> raise ("record type expected in extension of" +++ prt r +++ + "but found" +++ prt ty) + + ExtR ty ex -> do + r' <- justCheck r ty + s' <- justCheck s ex + return $ (ExtR r' s', typ) --- is this all? + + _ -> prtFail "record extension not meaningful for" typ + + FV vs -> do + ttys <- mapM (flip check typ) vs +--- checkIfComplexVariantType trm typ + return (FV (map fst ttys), typ) --- typ' ? + + S tab arg -> checks [ do + (tab',ty) <- infer tab + ty' <- comp ty + case ty' of + Table p t -> do + (arg',val) <- check arg p + checkEq typ t trm + return (S tab' arg', t) + _ -> raise $ "table type expected for applied table instead of" +++ + prtType env ty' + , do + (arg',ty) <- infer arg + ty' <- comp ty + (tab',_) <- check tab (Table ty' typ) + return (S tab' arg', typ) + ] + Let (x,(mty,def)) body -> case mty of + Just ty -> do + (def',ty') <- check def ty + checkUpdate (x,ty') + body' <- justCheck body typ + checkReset + return (Let (x,(Just ty',def')) body', typ) + _ -> do + (def',ty) <- infer def -- tries to infer type of local constant + check (Let (x,(Just ty,def')) body) typ + + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + where + cnc = env + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + checkEq = checkEqLType env + + recParts rr t = (RecType rr1,RecType rr2) where + (rr1,rr2) = partition (flip elem (map fst t) . fst) rr + + checkM rms (l,ty) = case lookup l rms of + Just (Just ty0,t) -> do + checkEq ty ty0 t + (t',ty') <- check t ty + return (l,(Just ty',t')) + Just (_,t) -> do + (t',ty') <- check t ty + return (l,(Just ty',t')) + _ -> prtFail "cannot find value for label" l + + checkCase arg val (p,t) = do + cont <- pattContext env arg p + i <- checkUpdates cont + t' <- justCheck t val + checkResets i + return (p,t') + +pattContext :: LTEnv -> Type -> Patt -> Check Context +pattContext env typ p = case p of + PV x | not (isWildIdent x) -> return [(x,typ)] + PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 + t <- checkErr $ lookupResType cnc q c + (cont,v) <- checkErr $ typeFormCnc t + checkCond ("wrong number of arguments for constructor in" +++ prt p) + (length cont == length ps) + checkEqLType env typ v (patt2term p) + mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat + PR r -> do + typ' <- computeLType env typ + case typ' of + RecType t -> do + let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] + ----- checkWarn $ prt p ++++ show pts ----- debug + mapM (uncurry (pattContext env)) pts >>= return . concat + _ -> prtFail "record type expected for pattern instead of" typ' + PT t p' -> do + checkEqLType env typ t (patt2term p') + pattContext env typ p' + + PAs x p -> do + g <- pattContext env typ p + return $ (x,typ):g + + PAlt p' q -> do + g1 <- pattContext env typ p' + g2 <- pattContext env typ q + let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] + checkCond + ("incompatible bindings of" +++ + unwords (nub (map (prt . fst) pts))+++ + "in pattern alterantives" +++ prt p) (null pts) + return g1 -- must be g1 == g2 + PSeq p q -> do + g1 <- pattContext env typ p + g2 <- pattContext env typ q + return $ g1 ++ g2 + PRep p' -> noBind typeStr p' + PNeg p' -> noBind typ p' + + _ -> return [] ---- check types! + where + cnc = env + noBind typ p' = do + co <- pattContext env typ p' + if not (null co) + then checkWarn ("no variable bound inside pattern" +++ prt p) + >> return [] + else return [] + +-- auxiliaries + +type LTEnv = SourceGrammar + +termWith :: Term -> Check Type -> Check (Term, Type) +termWith t ct = do + ty <- ct + return (t,ty) + +-- | light-weight substitution for dep. types +substituteLType :: Context -> Type -> Check Type +substituteLType g t = case t of + Vr x -> return $ maybe t id $ lookup x g + _ -> composOp (substituteLType g) t + +-- | compositional check\/infer of binary operations +check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> + Term -> Term -> Type -> Check (Term,Type) +check2 chk con a b t = do + a' <- chk a + b' <- chk b + return (con a' b', t) + +checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type +checkEqLType env t u trm = do + (b,t',u',s) <- checkIfEqLType env t u trm + case b of + True -> return t' + False -> raise $ s +++ "type of" +++ prt trm +++ + ": expected:" +++ prtType env t ++++ + "inferred:" +++ prtType env u + +checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) +checkIfEqLType env t u trm = do + t' <- comp t + u' <- comp u + case t' == u' || alpha [] t' u' of + True -> return (True,t',u',[]) + -- forgive missing lock fields by only generating a warning. + --- better: use a flag to forgive? (AR 31/1/2006) + _ -> case missingLock [] t' u' of + Ok lo -> do + checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) + return (True,t',u',[]) + Bad s -> return (False,t',u',s) + + where + + -- t is a subtype of u + --- quick hack version of TC.eqVal + alpha g t u = case (t,u) of + + -- error (the empty type!) is subtype of any other type + (_,Q (IC "Predef") (IC "Error")) -> True + + -- contravariance + (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d + + -- record subtyping + (RecType rs, RecType ts) -> all (\ (l,a) -> + any (\ (k,b) -> alpha g a b && l == k) ts) rs + (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' + (ExtR r s, t) -> alpha g r t || alpha g s t + + -- the following say that Ints n is a subset of Int and of Ints m >= n + (App (Q (IC "Predef") (IC "Ints")) (EInt n), + App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n + (App (Q (IC "Predef") (IC "Ints")) (EInt n), + Q (IC "Predef") (IC "Int")) -> True ---- check size! + + (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 + App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True + + ---- this should be made in Rename + (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + || m == n --- for Predef + (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + + (Table a b, Table c d) -> alpha g a c && alpha g b d + (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g + _ -> t == u + --- the following should be one-way coercions only. AR 4/1/2001 + || elem t sTypes && elem u sTypes + || (t == typeType && u == typePType) + || (u == typeType && t == typePType) + + missingLock g t u = case (t,u) of + (RecType rs, RecType ts) -> + let + ls = [l | (l,a) <- rs, + not (any (\ (k,b) -> alpha g a b && l == k) ts)] + (locks,others) = partition isLockLabel ls + in case others of + _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) + _ -> return locks + -- contravariance + (Prod x a b, Prod y c d) -> do + ls1 <- missingLock g c a + ls2 <- missingLock g b d + return $ ls1 ++ ls2 + + _ -> Bad "" + + sTypes = [typeStr, typeTok, typeString] + comp = computeLType env + +-- printing a type with a lock field lock_C as C +prtType :: LTEnv -> Type -> String +prtType env ty = case ty of + RecType fs -> case filter isLockLabel $ map fst fs of + [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty + _ -> prtt ty + Prod x a b -> prtType env a +++ "->" +++ prtType env b + _ -> prtt ty + where + prtt t = prt t + ---- use computeLType gr to check if really equal to the cat with lock + + +-- | linearization types and defaults +linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) +linTypeOfType cnc m typ = do + (cont,cat) <- checkErr $ typeSkeleton typ + val <- lookLin cat + args <- mapM mkLinArg (zip [0..] cont) + return (args, val) + where + mkLinArg (i,(n,mc@(m,cat))) = do + val <- lookLin mc + let vars = mkRecType varLabel $ replicate n typeStr + symb = argIdent n cat i + rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ + plusRecType vars val + return (symb,rec) + lookLin (_,c) = checks [ --- rather: update with defLinType ? + checkErr (lookupLincat cnc m c) >>= computeLType cnc + ,return defLinType + ] + +-- | dependency check, detecting circularities and returning topo-sorted list + +allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] +allOperDependencies m = allDependencies (==m) + +allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] +allDependencies ism b = + [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] + where + opersIn t = case t of + Q n c | ism n -> [c] + QC n c | ism n -> [c] + _ -> collectOp opersIn t + opty (Yes ty) = opersIn ty + opty _ = [] + pts i = case i of + ResOper pty pt -> [pty,pt] + ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont] + CncCat pty _ _ -> [pty] + CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) + AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual + AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co] + _ -> [] + +topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] +topoSortOpers st = do + let eops = topoTest st + either + return + (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) + eops diff --git a/src-3.0/GF/Compile/Compile.hs b/src-3.0/GF/Compile/Compile.hs new file mode 100644 index 000000000..422df0fd5 --- /dev/null +++ b/src-3.0/GF/Compile/Compile.hs @@ -0,0 +1,401 @@ +---------------------------------------------------------------------- +-- | +-- Module : Compile +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/05 20:02:19 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.45 $ +-- +-- The top-level compilation chain from source file to gfc\/gfr. +----------------------------------------------------------------------------- + +module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne, + CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts, + getGFEFiles) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Infra.CompactPrint +import GF.Grammar.PrGrammar +import GF.Compile.Update +import GF.Grammar.Lookup +import GF.Infra.Modules +import GF.Infra.ReadFiles +import GF.Compile.ShellState +import GF.Compile.MkResource +---- import MkUnion + +-- the main compiler passes +import GF.Compile.GetGrammar +import GF.Compile.Extend +import GF.Compile.Rebuild +import GF.Compile.Rename +import GF.Grammar.Refresh +import GF.Compile.CheckGrammar +import GF.Compile.Optimize +import GF.Compile.Evaluate +import GF.Compile.GrammarToCanon +--import GF.Devel.GrammarToGFCC ----- +import GF.Devel.OptimizeGF (subexpModule,unsubexpModule) +import GF.Canon.Share +import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) +import GF.UseGrammar.Linear (unoptimizeCanonMod) ---- + +import qualified GF.Canon.CanonToGrammar as CG + +import qualified GF.Canon.GFC as GFC +import qualified GF.Canon.MkGFC as MkGFC +import GF.Canon.GetGFC + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Text.UTF8 ---- +import GF.System.Arch + +import Control.Monad +import System.Directory +import System.FilePath + +-- | in batch mode: write code in a file +batchCompile f = liftM fst $ compileModule defOpts emptyShellState f + where + defOpts = options [emitCode] +batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f + where + defOpts = options [emitCode, optimizeCanon] + +batchCompileOld f = compileOld defOpts f + where + defOpts = options [emitCode] + +-- | compile with one module as starting point +-- command-line options override options (marked by --#) in the file +-- As for path: if it is read from file, the file path is prepended to each name. +-- If from command line, it is used as it is. +compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv +---- IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))])) + +compileModule opts st0 file | + oElem showOld opts || + elem suff [".cf",".ebnf",".gfm"] = do + let putp = putPointE opts + let putpp = putPointEsil opts + let path = [] ---- + grammar1 <- case suff of + ".cf" -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file + ".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file + ".gfm" -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file + _ -> putp ("- parsing old gf" +++ file) $ getOldGrammar opts file + let mods = modules grammar1 + let env = compileEnvShSt st0 [] + foldM (comp putpp path) env mods + where + suff = takeExtensions file + comp putpp path env sm0 = do + (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 + cm <- putpp " generating code... " $ generateModuleCode opts path sm + ft <- getReadTimes file --- + extendCompileEnvInt env (k',sm,cm) eenv' ft + +compileModule opts1 st0 file = do + opts0 <- ioeIO $ getOptionsFromFile file + let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList + let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList + let opts = addOptions opts1 opts0 + let fpath = dropFileName file + ps0 <- ioeIO $ pathListOpts opts fpath + + let ps1 = if (useFileOpt && not useLineOpt) + then (ps0 ++ map (combine fpath) ps0) + else ps0 + ps <- ioeIO $ extendPathEnv ps1 + let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) + ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- + let st = st0 --- if useFileOpt then emptyShellState else st0 + let rfs = [(m,t) | (m,(_,t)) <- readFiles st] + let file' = if useFileOpt then takeFileName file else file -- to find file itself + files <- getAllFiles opts ps rfs file' + ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- + let names = map justModuleName files + ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- + let env0 = compileEnvShSt st names + (e,mm) <- foldIOE (compileOne opts) env0 files + maybe (return ()) putStrLnE mm + return e + +getReadTimes file = do + t <- ioeIO getNowTime + let m = justModuleName file + return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)] + +compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv +compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where + cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i] + sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i] + notInc i = notElem (prt i) $ map dropExtension fs + notIns i = notElem (prt i) $ map dropExtension fs + fts = readFiles st + eenv = evalEnv st + +pathListOpts :: Options -> FileName -> IO [InitPath] +pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList + +reverseModules (MGrammar ms) = MGrammar $ reverse ms + +keepResModules :: Options -> SourceGrammar -> SourceGrammar +keepResModules opts gr = + if oElem retainOpers opts + then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m] + else emptyMGrammar + + +-- | the environment +type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv) + +emptyCompileEnv :: TimedCompileEnv +emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[]) + +extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft = + return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later + +extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm) + +extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft = + return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts) + +type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))]) + +compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv +compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do + + let putp = putPointE opts + let putpp = putPointEsil opts + let putpOpt v m act + | oElem beVerbose opts = putp v act + | oElem beSilent opts = putpp v act + | otherwise = ioeIO (putStrFlush m) >> act + + let gf = takeExtensions file + let path = dropFileName file + let name = dropExtension file + let mos = modules srcgr + + case gf of + -- for multilingual canonical gf, just read the file and update environment + ".gfcm" -> do + cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file + ft <- getReadTimes file + extendCompileEnvCanon env cgr eenv ft + + -- for canonical gf, read the file and update environment, also source env + ".gfc" -> do + cm <- putp ("+ reading" +++ file) $ getCanonModule file + let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 + sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm + ft <- getReadTimes file + extendCompileEnv env (sm, cm) eenv ft + + -- for compiled resource, parse and organize, then update environment + ".gfr" -> do + sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file + let sm1 = unsubexpModule sm0 + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 +---- experiment with not optimizing gfr +---- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1 + let gfc = gfcFile name + cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc + ft <- getReadTimes file + extendCompileEnv env (sm,cm) eenv ft + + -- for gf source, do full compilation + + _ -> do + + --- hack fix to a bug in ReadFiles with reused concrete + + let modu = dropExtension file + b1 <- ioeIO $ doesFileExist file + b2 <- ioeIO $ doesFileExist $ gfrFile modu + if not b1 + then if b2 + then compileOne opts env $ gfrFile $ modu + else compileOne opts env $ gfcFile $ modu + else do + + sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ + getSourceModule opts file + (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 + cm <- putpp " generating code... " $ generateModuleCode opts path sm + ft <- getReadTimes file + + sm':_ <- case snd sm of +---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm + _ -> return [sm] + + extendCompileEnvInt env (k',sm',cm) eenv' ft + +-- | dispatch reused resource at early stage +makeSourceModule :: Options -> CompileEnv -> + SourceModule -> IOE (Int,SourceModule,EEnv) +makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of + + ModMod m -> case mtype m of + MTReuse c -> do + sm <- ioeErr $ makeReuse gr i (extend m) c + let mo2 = (i, ModMod sm) + mos = modules gr + --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 + return $ (k,mo2,eenv) +{- ---- obsolete + MTUnion ty imps -> do + mo' <- ioeErr $ makeUnion gr i ty imps + compileSourceModule opts env mo' +-} + + _ -> compileSourceModule opts env mo + _ -> compileSourceModule opts env mo + where + putp = putPointE opts + +compileSourceModule :: Options -> CompileEnv -> + SourceModule -> IOE (Int,SourceModule,EEnv) +compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do + + let putp = putPointE opts + putpp = putPointEsil opts + mos = modules gr + + if (oElem showOld opts && oElem emitCode opts) + then do + let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo])) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file out + else return () + + mo1 <- ioeErr $ rebuildModule mos mo + + mo1b <- ioeErr $ extendModule mos mo1 + + case mo1b of + (_,ModMod n) | not (isCompleteModule n) -> do + return (k,mo1b,eenv) -- refresh would fail, since not renamed + _ -> do + mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b + + (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 + if null warnings then return () else putp warnings $ return () + + (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 + + (mo4,eenv') <- + ---- if oElem "check_only" opts + putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r + return (k',mo4,eenv') + where + ---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug + prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo] + +generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule +generateModuleCode opts path minfo@(name,info) = do + +--- DEPREC +--- if oElem (iOpt "gfcc") opts +--- then ioeIO $ putStrLn $ prGrammar2gfcc minfo +--- else return () + + let pname = path prt name + minfo0 <- ioeErr $ redModInfo minfo + let oopts = addOptions opts (iOpts (flagsModule minfo)) + optims = maybe "all_subs" id $ getOptVal oopts useOptimizer + optim = takeWhile (/='_') optims + subs = drop 1 (dropWhile (/='_') optims) == "subs" + minfo1 <- return $ + case optim of + "parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing + "values" -> shareModule valOpt minfo0 -- tables as courses-of-values + "share" -> shareModule shareOpt minfo0 -- sharing of branches + "all" -> shareModule allOpt minfo0 -- first parametrize then values + "none" -> minfo0 -- no optimization + _ -> shareModule shareOpt minfo0 -- sharing; default + + -- do common subexpression elimination if required by flag "subs" + minfo' <- + if subs + then ioeErr $ elimSubtermsMod minfo1 + else return minfo1 + + -- for resource, also emit gfr. + --- Also for incomplete, to create timestamped gfc/gfr files + case info of + ModMod m | emitsGFR m && emit && nomulti -> do + let rminfo = if isCompilable info + then subexpModule minfo + else (name, ModMod emptyModule) + let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo])) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out + _ -> return () + let encode = case getOptVal opts uniCoding of + Just "utf8" -> encodeUTF8 + _ -> id + (file,out) <- do + code <- return $ MkGFC.prCanonModInfo minfo' + return (gfcFile pname, encode code) + if emit && nomulti ---- && isCompilable info + then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out + else putpp ("no need to save module" +++ prt name) $ return () + return minfo' + where + putp = putPointE opts + putpp = putPointEsil opts + + emitsGFR m = isModRes m ---- && isCompilable info + ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete) + isCompilable mi = case mi of + ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete + _ -> True + nomulti = not $ oElem makeMulti opts + emit = oElem emitCode opts && not (oElem notEmitCode opts) + +-- for old GF: sort into modules, write files, compile as usual + +compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar +compileOld opts file = do + let putp = putPointE opts + grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file + files <- mapM writeNewGF $ modules grammar1 + ((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files + return grammar + +writeNewGF :: SourceModule -> IOE FilePath +writeNewGF m@(i,_) = do + let file = gfFile $ prt i + ioeIO $ writeFile file $ prGrammar (MGrammar [m]) + ioeIO $ putStrLn $ "wrote file" +++ file + return file + +--- this function duplicates a lot of code from compileModule. +--- It does not really belong here either. +-- It selects those .gfe files that a grammar depends on and that +-- are younger than corresponding gf + +getGFEFiles :: Options -> FilePath -> IO [FilePath] +getGFEFiles opts1 file = useIOE [] $ do + opts0 <- ioeIO $ getOptionsFromFile file + let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList + let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList + let opts = addOptions opts1 opts0 + let fpath = dropFileName file + ps0 <- ioeIO $ pathListOpts opts fpath + + let ps1 = if (useFileOpt && not useLineOpt) + then (map (combine fpath) ps0) + else ps0 + ps <- ioeIO $ extendPathEnv ps1 + let file' = if useFileOpt then takeFileName file else file -- to find file itself + files <- getAllFiles opts ps [] file' + efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files] + es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf + return $ filter ((=='e') . last) es diff --git a/src-3.0/GF/Compile/Evaluate.hs b/src-3.0/GF/Compile/Evaluate.hs new file mode 100644 index 000000000..a574fef40 --- /dev/null +++ b/src-3.0/GF/Compile/Evaluate.hs @@ -0,0 +1,477 @@ +---------------------------------------------------------------------- +-- | +-- Module : Evaluate +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/01 15:39:12 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.19 $ +-- +-- Computation of source terms. Used in compilation and in @cc@ command. +----------------------------------------------------------------------------- + +module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where + +import GF.Data.Operations +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Data.Str +import GF.Grammar.PrGrammar +import GF.Infra.Modules +import GF.Infra.Option +import GF.Grammar.Macros +import GF.Grammar.Lookup +import GF.Grammar.Refresh +import GF.Grammar.PatternMatch +import GF.Grammar.Lockfield (isLockLabel) ---- + +import GF.Grammar.AppPredefined + +import qualified Data.Map as Map + +import Data.List (nub,intersperse) +import Control.Monad (liftM2, liftM) +import Debug.Trace + + +data EEnv = EEnv { + computd :: Map.Map (Ident,Ident) FTerm, + temp :: Int + } + +emptyEEnv = EEnv Map.empty 0 + +lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm) +lookupComputed mc = do + env <- readSTM + return $ Map.lookup mc $ computd env + +updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv () +updateComputed mc t = + updateSTM (\e -> e{computd = Map.insert mc t (computd e)}) + +getTemp :: STM EEnv Ident +getTemp = do + env <- readSTM + updateSTM (\e -> e{temp = temp e + 1}) + return $ identC ("#" ++ show (temp env)) + +data FTerm = + FTC Term + | FTF (Term -> FTerm) + +prFTerm :: Integer -> FTerm -> String +prFTerm i t = case t of + FTC t -> prt t + FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i)) + +term2fterm t = case t of + Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b)) + _ -> FTC t + +traceFTerm c ft = ft ---- +----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft + +fterm2term :: FTerm -> STM EEnv Term +fterm2term t = case t of + FTC t -> return t + FTF f -> do + x <- getTemp + b <- fterm2term $ f (Vr x) + return $ Abs x b + +subst g t = case t of + Vr x -> maybe t id $ lookup x g + _ -> composSafeOp (subst g) t + + +appFTerm :: FTerm -> [Term] -> FTerm +appFTerm ft ts = case (ft,ts) of + (FTF f, x:xs) -> appFTerm (f x) xs + (FTC c, _:_) -> FTC $ foldl App c ts + _ -> ft + +apps :: Term -> (Term,[Term]) +apps t = case t of + App f a -> (f',xs ++ [a]) where (f',xs) = apps f + _ -> (t,[]) + +appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env + +evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info) +evalConcrete gr mo = mapMTree evaldef mo where + + evaldef (f,info) = case info of + CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> + evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $ + do + pde' <- case pde of + Yes de -> do + liftM yes $ pEval ty de + _ -> return pde + --- ppr' <- liftM yes $ evalPrintname gr c ppr pde' + return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed + + _ -> return (f,info) + + pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do + let + vars = map fst context + args = map Vr vars + subst = [(v, Vr v) | v <- vars] + trm1 = mkApp trm args + trm3 <- recordExpand val trm1 >>= comp subst >>= recomp subst + return $ mkAbs vars trm3 + + ---- temporary hack to ascertain full evaluation, because of bug in comp + recomp g t = if notReady t then comp g t else return t + notReady = not . null . redexes + redexes t = case t of + Q _ _ -> return [()] + _ -> collectOp redexes t + + recordExpand typ trm = case unComputed typ of + RecType tys -> case trm of + FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] + _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] + _ -> return trm + + comp g t = case t of + + Q (IC "Predef") _ -> return t ----trace ("\nPredef:\n" ++ prt t) $ return t + + Q p c -> do + md <- lookupComputed (p,c) + case md of + Nothing -> do + d <- lookRes (p,c) + updateComputed (p,c) $ traceFTerm c $ term2fterm d + return d + Just d -> fterm2term d >>= comp g + App f a -> case apps t of +{- ---- + (h@(QC p c),xs) -> do + xs' <- mapM (comp g) xs + case lookupValueIndex gr ty t of + Ok v -> return v + _ -> return t +-} + (h@(Q p c),xs) | p == IC "Predef" -> do + xs' <- mapM (comp g) xs + (t',b) <- stmErr $ appPredefined (foldl App h xs') + if b then return t' else comp g t' + (h@(Q p c),xs) -> do + xs' <- mapM (comp g) xs + md <- lookupComputed (p,c) + case md of + Just ft -> do + t <- fterm2term $ appFTerm ft xs' + comp g t + Nothing -> do + d <- lookRes (p,c) + let ft = traceFTerm c $ term2fterm d + updateComputed (p,c) ft + t' <- fterm2term $ appFTerm ft xs' + comp g t' + _ -> do + f' <- comp g f + a' <- comp g a + case (f',a') of + (Abs x b,_) -> comp (ext x a' g) b + (QC _ _,_) -> returnC $ App f' a' + (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants + (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants + + (Alias _ _ d, _) -> comp g (App d a') + + (S (T i cs) e,_) -> prawitz g i (flip App a') cs e + + _ -> do + (t',b) <- stmErr $ appPredefined (App f' a') + if b then return t' else comp g t' + + + Vr x -> do + t' <- maybe (prtRaise ( + "context" +++ show g +++ ": no value given to variable") x) return $ lookup x g + case t' of + _ | t == t' -> return t + _ -> comp g t' + + Abs x b -> do + b' <- comp (ext x (Vr x) g) b + return $ Abs x b' + + Let (x,(_,a)) b -> do + a' <- comp g a + comp (ext x a' g) b + + Prod x a b -> do + a' <- comp g a + b' <- comp (ext x (Vr x) g) b + return $ Prod x a' b' + + P t l | isLockLabel l -> return $ R [] + ---- a workaround 18/2/2005: take this away and find the reason + ---- why earlier compilation destroys the lock field + + + P t l -> do + t' <- comp g t + case t' of + FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants + R r -> maybe + (prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $ + lookup l r + + ExtR a (R b) -> case lookup l b of ----comp g (P (R b) l) of + Just (_,v) -> comp g v + _ -> comp g (P a l) + ExtR (R a) b -> case lookup l a of ----comp g (P (R b) l) of + Just (_,v) -> comp g v + _ -> comp g (P b l) + + S (T i cs) e -> prawitz g i (flip P l) cs e + + _ -> returnC $ P t' l + + S t@(T _ cc) v -> do + v' <- comp g v + case v' of + FV vs -> do + ts' <- mapM (comp g . S t) vs + return $ variants ts' + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + + S t v -> do + t' <- comp g t + v' <- comp g v + case t' of + T _ [(PV IW,c)] -> comp g c --- an optimization + T _ [(PT _ (PV IW),c)] -> comp g c + + T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization + T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c + + FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants + + V ptyp ts -> do + vs <- stmErr $ allParamValues gr ptyp + ps <- stmErr $ mapM term2patt vs + let cc = zip ps ts + case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + T _ cc -> case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + Alias _ _ d -> comp g (S d v') + + S (T i cs) e -> prawitz g i (flip S v') cs e + + _ -> returnC $ S t' v' + + -- normalize away empty tokens + K "" -> return Empty + + -- glue if you can + Glue x0 y0 -> do + x <- comp g x0 + y <- comp g y0 + case (x,y) of + (Alias _ _ d, y) -> comp g $ Glue d y + (x, Alias _ _ d) -> comp g $ Glue x d + + (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e + (s, S (T i cs) e) -> prawitz g i (Glue s) cs e + (_,Empty) -> return x + (Empty,_) -> return y + (K a, K b) -> return $ K (a ++ b) + (_, Alts (d,vs)) -> do +---- (K a, Alts (d,vs)) -> do + let glx = Glue x + comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) + (Alts _, ka) -> checks [do + y' <- stmErr $ strsFromTerm ka +---- (Alts _, K a) -> checks [do + x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] +---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] + ,return $ Glue x y + ] + (FV ks,_) -> do + kys <- mapM (comp g . flip Glue y) ks + return $ variants kys + (_,FV ks) -> do + xks <- mapM (comp g . Glue x) ks + return $ variants xks + + _ -> do + mapM_ checkNoArgVars [x,y] + r <- composOp (comp g) t + returnC r + + Alts _ -> do + r <- composOp (comp g) t + returnC r + + -- remove empty + C a b -> do + a' <- comp g a + b' <- comp g b + case (a',b') of + (Alts _, K a) -> checks [do + as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] + , + return $ C a' b' + ] + (Empty,_) -> returnC b' + (_,Empty) -> returnC a' + _ -> returnC $ C a' b' + + -- reduce free variation as much as you can + FV ts -> mapM (comp g) ts >>= returnC . variants + + -- merge record extensions if you can + ExtR r s -> do + r' <- comp g r + s' <- comp g s + case (r',s') of + (Alias _ _ d, _) -> comp g $ ExtR d s' + (_, Alias _ _ d) -> comp g $ Glue r' d + + (R rs, R ss) -> stmErr $ plusRecord r' s' + (RecType rs, RecType ss) -> stmErr $ plusRecType r' s' + + (_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss] + + _ -> return $ ExtR r' s' + + -- case-expand tables + -- if already expanded, don't expand again + T i@(TComp _) cs -> do + -- if there are no variables, don't even go inside + cs' <- {-if (null g) then return cs else-} mapPairsM (comp g) cs + return $ T i cs' + + --- this means some extra work; should implement TSh directly + TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] + + T i cs -> do + pty0 <- stmErr $ getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs -> do + + cs' <- mapM (compBranchOpt g) cs + sts <- stmErr $ mapM (matchPattern cs') vs + ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts + ps <- stmErr $ mapM term2patt vs + let ps' = ps --- PT ptyp (head ps) : tail ps + return $ --- V ptyp ts -- to save space, just course of values + T (TComp ptyp) (zip ps' ts) + _ -> do + cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + + -- otherwise go ahead + _ -> composOp (comp g) t >>= returnC + + lookRes (p,c) = case lookupResDefKind gr p c of + Ok (t,_) | noExpand p -> return t + Ok (t,0) -> comp [] t + Ok (t,_) -> return t + Bad s -> raise s + + noExpand p = errVal False $ do + mo <- lookupModMod gr p + return $ case getOptVal (iOpts (flags mo)) useOptimizer of + Just "noexpand" -> True + _ -> False + + prtRaise s t = raise (s +++ prt t) + + ext x a g = (x,a):g + + returnC = return --- . computed + + variants ts = case nub ts of + [t] -> t + ts -> FV ts + + isCan v = case v of + Con _ -> True + QC _ _ -> True + App f a -> isCan f && isCan a + R rs -> all (isCan . snd . snd) rs + _ -> False + + compBranch g (p,v) = do + let g' = contP p ++ g + v' <- comp g' v + return (p,v') + + compBranchOpt g c@(p,v) = case contP p of + [] -> return c + _ -> compBranch g c +---- _ -> err (const (return c)) return $ compBranch g c + + contP p = case p of + PV x -> [(x,Vr x)] + PC _ ps -> concatMap contP ps + PP _ _ ps -> concatMap contP ps + PT _ p -> contP p + PR rs -> concatMap (contP . snd) rs + + PAs x p -> (x,Vr x) : contP p + + PSeq p q -> concatMap contP [p,q] + PAlt p q -> concatMap contP [p,q] + PRep p -> contP p + PNeg p -> contP p + + _ -> [] + + prawitz g i f cs e = do + cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] + return $ S (T i cs') e + +-- | argument variables cannot be glued +checkNoArgVars :: Term -> STM EEnv Term +checkNoArgVars t = case t of + Vr (IA _) -> raise $ glueErrorMsg $ prt t + Vr (IAV _) -> raise $ glueErrorMsg $ prt t + _ -> composOp checkNoArgVars t + +glueErrorMsg s = + "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ + "Use Prelude.bind instead." + +stmErr :: Err a -> STM s a +stmErr e = stm (\s -> do + v <- e + return (v,s) + ) + +evalIn :: String -> STM s a -> STM s a +evalIn msg st = stm $ \s -> case appSTM st s of + Bad e -> Bad $ msg ++++ e + Ok vs -> Ok vs diff --git a/src-3.0/GF/Compile/Extend.hs b/src-3.0/GF/Compile/Extend.hs new file mode 100644 index 000000000..ae87b3e71 --- /dev/null +++ b/src-3.0/GF/Compile/Extend.hs @@ -0,0 +1,136 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/Flatten.hs b/src-3.0/GF/Compile/Flatten.hs new file mode 100644 index 000000000..6b25edebb --- /dev/null +++ b/src-3.0/GF/Compile/Flatten.hs @@ -0,0 +1,92 @@ +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-3.0/GF/Compile/GetGrammar.hs b/src-3.0/GF/Compile/GetGrammar.hs new file mode 100644 index 000000000..294edbf9a --- /dev/null +++ b/src-3.0/GF/Compile/GetGrammar.hs @@ -0,0 +1,146 @@ +---------------------------------------------------------------------- +-- | +-- Module : GetGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/15 17:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.16 $ +-- +-- this module builds the internal GF grammar that is sent to the type checker +----------------------------------------------------------------------------- + +module GF.Compile.GetGrammar ( + getSourceModule, getSourceGrammar, + getOldGrammar, getCFGrammar, getEBNFGrammar + ) where + +import GF.Data.Operations +import qualified GF.Source.ErrM as E + +import GF.Infra.UseIO +import GF.Grammar.Grammar +import GF.Infra.Modules +import GF.Grammar.PrGrammar +import qualified GF.Source.AbsGF as A +import GF.Source.SourceToGrammar +---- import Macros +---- import Rename +import GF.Text.UTF8 ---- +import GF.Infra.Option +--- import Custom +import GF.Source.ParGF +import qualified GF.Source.LexGF as L + +import GF.CF.CF (rules2CF) +import GF.CF.PPrCF +import GF.CF.CFtoGrammar +import GF.CF.EBNF + +import GF.Infra.ReadFiles ---- + +import Data.Char (toUpper) +import Data.List (nub) +import qualified Data.ByteString.Char8 as BS +import Control.Monad (foldM) +import System (system) +import System.FilePath + +getSourceModule :: Options -> FilePath -> IOE SourceModule +getSourceModule opts file0 = do + file <- case getOptVal opts usePreprocessor of + Just p -> do + let tmp = "_gf_preproc.tmp" + cmd = p +++ file0 ++ ">" ++ tmp + ioeIO $ system cmd + -- ioeIO $ putStrLn $ "preproc" +++ cmd + return tmp + _ -> return file0 + string0 <- readFileIOE file + let string = case getOptVal opts uniCoding of + Just "utf8" -> decodeUTF8 string0 + _ -> string0 + let tokens = myLexer (BS.pack string) + mo1 <- ioeErr $ pModDef tokens + ioeErr $ transModDef mo1 + +getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar +getSourceGrammar opts file = do + string <- readFileIOE file + let tokens = myLexer (BS.pack string) + gr1 <- ioeErr $ pGrammar tokens + ioeErr $ transGrammar gr1 + + +-- for old GF format with includes + +getOldGrammar :: Options -> FilePath -> IOE SourceGrammar +getOldGrammar opts file = do + defs <- parseOldGrammarFiles file + let g = A.OldGr A.NoIncl defs + let name = takeFileName file + ioeErr $ transOldGrammar opts name g + +parseOldGrammarFiles :: FilePath -> IOE [A.TopDef] +parseOldGrammarFiles file = do + putStrLnE $ "reading grammar of old format" +++ file + (_, g) <- getImports "" ([],[]) file + return g -- now we can throw away includes + where + getImports oldInitPath (oldImps, oldG) f = do + (path,s) <- readFileLibraryIOE oldInitPath f + if not (elem path oldImps) + then do + (imps,g) <- parseOldGrammar path + foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps + else + return (oldImps, oldG) + +parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef]) +parseOldGrammar file = do + putStrLnE $ "reading old file" +++ file + s <- ioeIO $ readFileIf file + A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s + includes <- ioeErr $ transInclude incl + return (includes, topdefs) + +---- + +-- | To resolve the new reserved words: +-- change them by turning the final letter to upper case. +--- There is a risk of clash. +oldLexer :: String -> [L.Token] +oldLexer = map change . L.tokens . BS.pack where + change t = case t of + (L.PT p (L.TS s)) | elem s newReservedWords -> + (L.PT p (L.TV (init s ++ [toUpper (last s)]))) + _ -> t + +getCFGrammar :: Options -> FilePath -> IOE SourceGrammar +getCFGrammar opts file = do + let mo = takeWhile (/='.') file + s <- ioeIO $ readFileIf file + let files = case words (concat (take 1 (lines s))) of + "--":"include":fs -> fs + _ -> [] + ss <- ioeIO $ mapM readFileIf files + cfs <- ioeErr $ mapM (pCF mo) $ s:ss + defs <- return $ cf2grammar $ rules2CF $ concat cfs + let g = A.OldGr A.NoIncl defs +--- let ma = justModuleName file +--- let mc = 'C':ma --- +--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts + ioeErr $ transOldGrammar opts file g + +getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar +getEBNFGrammar opts file = do + let mo = takeWhile (/='.') file + s <- ioeIO $ readFileIf file + defs <- ioeErr $ pEBNFasGrammar s + let g = A.OldGr A.NoIncl defs +--- let ma = justModuleName file +--- let mc = 'C':ma --- +--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts + ioeErr $ transOldGrammar opts file g diff --git a/src-3.0/GF/Compile/GrammarToCanon.hs b/src-3.0/GF/Compile/GrammarToCanon.hs new file mode 100644 index 000000000..09c0d3d95 --- /dev/null +++ b/src-3.0/GF/Compile/GrammarToCanon.hs @@ -0,0 +1,293 @@ +---------------------------------------------------------------------- +-- | +-- Module : GrammarToCanon +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.23 $ +-- +-- Code generator from optimized GF source code to GFC. +----------------------------------------------------------------------------- + +module GF.Compile.GrammarToCanon (showGFC, + redModInfo, redQIdent + ) where + +import GF.Data.Operations +import GF.Data.Zipper +import GF.Infra.Option +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Grammar.PrGrammar +import GF.Infra.Modules +import GF.Grammar.Macros +import qualified GF.Canon.AbsGFC as G +import qualified GF.Canon.GFC as C +import GF.Canon.MkGFC +---- import Alias +import qualified GF.Canon.PrintGFC as P + +import Control.Monad +import Data.List (nub,sortBy) + +-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003 + +-- | This is the top-level function printing a gfc file +showGFC :: SourceGrammar -> String +showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar + +-- | any grammar, first trying without dependent types +-- abstract syntax without dependent types +redGrammar :: SourceGrammar -> Err C.CanonGrammar +redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where + active (_,m) = case typeOfModule m of + MTInterface -> False + _ -> True + +redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo) +redModInfo (c,info) = do + c' <- redIdent c + info' <- case info of + ModMod m -> do + let isIncompl = not $ isCompleteModule m + (e,os) <- if isIncompl then return ([],[]) else redExtOpen m ---- + flags <- mapM redFlag $ flags m + (a,mt0) <- case mtype m of + MTConcrete a -> do + a' <- redIdent a + return (a', MTConcrete a') + MTAbstract -> return (c',MTAbstract) --- c' not needed + MTResource -> return (c',MTResource) --- c' not needed + MTInterface -> return (c',MTResource) ---- not needed + MTInstance _ -> return (c',MTResource) --- c' not needed + MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed + + --- this generates empty GFC reosurce for interface and incomplete + let js = if isIncompl then emptyBinTree else jments m + mt = mt0 ---- if isIncompl then MTResource else mt0 + + defss <- mapM (redInfo a) $ tree2list $ js + let defs0 = concat defss + let lgh = length defs0 + defs <- return $ sorted2tree $ defs0 -- sorted, but reduced + let flags1 = if isIncompl then C.flagIncomplete : flags else flags + let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1 + return $ ModMod $ Module mt MSComplete flags' e os defs + return (c',info') + where + redExtOpen m = do + e' <- case extends m of + es -> mapM (liftM inheritAll . redIdent) es + os' <- mapM (\o -> case o of + OQualif q _ i -> liftM (OSimple q) (redIdent i) + _ -> prtBad "cannot translate unqualified open in" c) $ opens m + return (e',nub os') + om = oSimple . openedModule --- normalizing away qualif + +redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)] +redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do + c' <- redIdent c + case info of + AbsCat (Yes cont) pfs -> do + let fs = case pfs of + Yes ts -> [(m,c) | Q m c <- ts] + _ -> [] + returns c' $ C.AbsCat cont fs + AbsFun (Yes typ) pdf -> do + let df = case pdf of + Yes t -> t -- definition or "data" + _ -> Eqs [] -- primitive notion + returns c' $ C.AbsFun typ df + AbsTrans t -> + returns c' $ C.AbsTrans t + + ResParam (Yes (ps,_)) -> do + ps' <- mapM redParam ps + returns c' $ C.ResPar ps' + + CncCat pty ptr ppr -> case (pty,ptr,ppr) of + (Yes ty, Yes (Abs _ t), Yes pr) -> do + ty' <- redCType ty + trm' <- redCTerm t + pr' <- redCTerm pr + return [(c', C.CncCat ty' trm' pr')] + _ -> prtBad ("cannot reduce rule for") c + + CncFun mt ptr ppr -> case (mt,ptr,ppr) of + (Just (cat,_), Yes trm, Yes pr) -> do + cat' <- redIdent cat + (xx,body,_) <- termForm trm + xx' <- mapM redArgvar xx + body' <- errIn (prt body) $ redCTerm body ---- debug + pr' <- redCTerm pr + return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')] + _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug + + AnyInd s b -> do + b' <- redIdent b + returns c' $ C.AnyInd s b' + + _ -> return [] --- retain some operations + where + returns f i = return [(f,i)] + +redQIdent :: QIdent -> Err G.CIdent +redQIdent (m,c) = return $ G.CIQ m c + +redIdent :: Ident -> Err Ident +redIdent x + | isWildIdent x = return $ identC "h_" --- needed in declarations + | otherwise = return $ identC $ prt x --- + +redFlag :: Option -> Err G.Flag +redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x) +redFlag o = Bad $ "cannot reduce option" +++ prOpt o + +redDecl :: Decl -> Err G.Decl +redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a) + +redType :: Type -> Err G.Exp +redType = redTerm + +redTerm :: Type -> Err G.Exp +redTerm t = return $ rtExp t + +-- to normalize records and record types +sortByFst :: Ord a => [(a,b)] -> [(a,b)] +sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) + +-- resource + +redParam :: Param -> Err G.ParDef +redParam (c,cont) = do + c' <- redIdent c + cont' <- mapM (redCType . snd) cont + return $ G.ParD c' cont' + +redArgvar :: Ident -> Err G.ArgVar +redArgvar x = case x of + IA (x,i) -> return $ G.A (identC x) (toInteger i) + IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i) + _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable" + +redLindef :: Term -> Err G.Term +redLindef t = case t of + Abs x b -> redCTerm b --- + _ -> redCTerm t + +redCType :: Type -> Err G.CType +redCType t = case t of + RecType lbs -> do + let (ls,ts) = unzip lbs + ls' = map redLabel ls + ts' <- mapM redCType ts + return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts' + Table p v -> liftM2 G.Table (redCType p) (redCType v) + Q m c -> liftM G.Cn $ redQIdent (m,c) + QC m c -> liftM G.Cn $ redQIdent (m,c) + + App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n) + + Sort "Str" -> return $ G.TStr + Sort "Tok" -> return $ G.TStr + _ -> prtBad "cannot reduce to canonical the type" t + +redCTerm :: Term -> Err G.Term +redCTerm t = case t of + Vr x -> checkAgain + (liftM G.Arg $ redArgvar x) + (liftM G.LI $ redIdent x) --- for parametrize optimization + App _ s -> do -- only constructor applications can remain + (_,c,xx) <- termForm t + xx' <- mapM redCTerm xx + case c of + QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx') + Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s + _ -> prtBad "expected constructor head instead of" c + Q p c -> liftM G.I (redQIdent (p,c)) + QC p c -> liftM2 G.Par (redQIdent (p,c)) (return []) + R rs -> do + let (ls,tts) = unzip rs + ls' = map redLabel ls + ts <- mapM (redCTerm . snd) tts + return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts + RecType [] -> return $ G.R [] --- comes out in parsing + P tr l -> do + tr' <- redCTerm tr + return $ G.P tr' (redLabel l) + PI tr l _ -> redCTerm $ P tr l ----- + T i cs -> do + ty <- getTableType i + ty' <- redCType ty + let (ps,ts) = unzip cs + ps' <- mapM redPatt ps + ts' <- mapM redCTerm ts + return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts' + TSh i cs -> do + ty <- getTableType i + ty' <- redCType ty + let (pss,ts) = unzip cs + pss' <- mapM (mapM redPatt) pss + ts' <- mapM redCTerm ts + return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts' + V ty ts -> do + ty' <- redCType ty + ts' <- mapM redCTerm ts + return $ G.V ty' ts' + S u v -> liftM2 G.S (redCTerm u) (redCTerm v) + K s -> return $ G.K (G.KS s) + EInt i -> return $ G.EInt i + EFloat i -> return $ G.EFloat i + C u v -> liftM2 G.C (redCTerm u) (redCTerm v) + FV ts -> liftM G.FV $ mapM redCTerm ts +--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete + + Alts (d,vs) -> do --- + d' <- redCTermTok d + vs' <- mapM redVariant vs + return $ G.K $ G.KP d' vs' + + Empty -> return $ G.E + +--- Strs ss -> return $ G.Strs [s | K s <- ss] --- + +---- Glue obsolete in canon, should not occur here + Glue x y -> redCTerm (C x y) + + _ -> Bad ("cannot reduce term" +++ prt t) + +redPatt :: Patt -> Err G.Patt +redPatt p = case p of + PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) + PR rs -> do + let (ls,tts) = unzip rs + ls' = map redLabel ls + ts <- mapM redPatt tts + return $ G.PR $ map (uncurry G.PAss) $ sortByFst $ zip ls' ts + PT _ q -> redPatt q + PInt i -> return $ G.PI i + PFloat i -> return $ G.PF i + PV x -> liftM G.PV $ redIdent x --- for parametrize optimization + _ -> prtBad "cannot reduce pattern" p + +redLabel :: Label -> G.Label +redLabel (LIdent s) = G.L $ identC s +redLabel (LVar i) = G.LV $ toInteger i + +redVariant :: (Term, Term) -> Err G.Variant +redVariant (v,c) = do + v' <- redCTermTok v + c' <- redCTermTok c + return $ G.Var v' c' + +redCTermTok :: Term -> Err [String] +redCTermTok t = case t of + K s -> return [s] + Empty -> return [] + C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b) + Strs ss -> return [s | K s <- ss] --- + _ -> prtBad "cannot get strings from term" t + diff --git a/src-3.0/GF/Compile/MkConcrete.hs b/src-3.0/GF/Compile/MkConcrete.hs new file mode 100644 index 000000000..d016a7e47 --- /dev/null +++ b/src-3.0/GF/Compile/MkConcrete.hs @@ -0,0 +1,154 @@ +---------------------------------------------------------------------- +-- | +-- Module : MkConcrete +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: +-- > CVS $Author: +-- > CVS $Revision: +-- +-- Compile a gfe file into a concrete syntax by using the parser on a resource grammar. +----------------------------------------------------------------------------- + +module GF.Compile.MkConcrete (mkConcretes) where + +import GF.Grammar.Values (Tree,tree2exp) +import GF.Grammar.PrGrammar (prt_,prModule) +import GF.Grammar.Grammar --- (Term(..),SourceModule) +import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent) +import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords) +import GF.Compile.PGrammar (pTerm,pTrm) +import GF.Compile.Compile +import GF.Compile.PrOld (stripTerm) +import GF.Compile.GetGrammar +import GF.API +import GF.API.IOGrammar +import qualified GF.Embed.EmbedAPI as EA + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Infra.Modules +import GF.Infra.ReadFiles +import GF.System.Arch +import GF.UseGrammar.Treebank + +import System.Directory +import System.FilePath +import Data.Char +import Control.Monad +import Data.List + +-- translate strings into lin rules by parsing in a resource +-- grammar. AR 2/6/2005 + +-- Format of rule (on one line): +-- lin F x y = in C "ssss" ; +-- Format of resource path (on first line): +-- --# -resource=PATH +-- Other lines are copied verbatim. +-- A sequence of files can be processed with the same resource without +-- rebuilding the grammar and parser. + +-- notice: we use a hand-crafted lexer and parser in order to preserve +-- the layout and comments in the rest of the file. + +mkConcretes :: Options -> [FilePath] -> IO () +mkConcretes opts files = do + ress <- mapM getResPath files + let grps = groupBy (\a b -> fst a == fst b) $ + sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files + mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps] + +mkCncGroups opts0 ((res,path),files) = do + putStrLnFlush $ "Going to preprocess examples in " ++ unwords files + putStrLn $ "Compiling resource " ++ res + let opts = addOptions (options [beSilent,pathList path]) opts0 + let treebank = oElem (iOpt "treebank") opts + resf <- useIOE res $ do + (fp,_) <- readFileLibraryIOE "" res + return fp + egr <- appIOE $ shellStateFromFiles opts emptyShellState resf + (parser,morpho) <- if treebank then do + tb <- err (\_ -> error $ "no treebank of name" +++ path) + return + (egr >>= flip findTreebank (zIdent path)) + return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb, + isWordInTreebank tb) + else do + gr <- err (\s -> putStrLn s >> error "resource grammar rejected") + (return . firstStateGrammar) egr + return + (\cat s -> + errVal ([],"No parse") $ + optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>= + (\ (ts,e) -> return (map tree2exp ts, e)) , + isKnownWord gr) + putStrLn "Building parser" + mapM_ (mkConcrete parser morpho) files + +type Parser = String -> String -> ([Term],String) +type Morpho = String -> Bool + +getResPath :: FilePath -> IO (String,String) +getResPath file = do + s <- liftM lines $ readFileIf file + case filter (not . all isSpace) s of + res:path:_ | is "resource" res && is "path" path -> return (val res, val path) + res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path) + res:_ | is "resource" res -> return (val res, "") + _ -> error + "expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT" + where + val = dropWhile (isSpace) . tail . dropWhile (not . (=='=')) + is tag s = case words s of + "--#":w:_ -> isPrefixOf ('-':tag) w + _ -> False + + +mkConcrete :: Parser -> Morpho -> FilePath -> IO () +mkConcrete parser morpho file = do + src <- appIOE (getSourceModule noOptions file) >>= err error return + let (src',msgs) = mkModule parser morpho src + let out = addExtension (justModuleName file) "gf" + writeFile out $ "-- File generated by GF from " ++ file + appendFile out "\n" + appendFile out (prModule src') + appendFile out "{-\n" + appendFile out $ unlines $ filter (not . null) msgs + appendFile out "-}\n" + +mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String]) +mkModule parser morpho (name,src) = case src of + ModMod m@(Module mt st fs me ops js) -> + + let js1 = jments m + (js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) [] + mod2 = ModMod $ Module mt st fs me ops $ js2 + in ((name,mod2), msgs) + where + mkInfo ni@(name,info) = case info of + CncFun mt (Yes trm) ppr -> do + trm' <- mkTrm trm + return (name, CncFun mt (Yes trm') ppr) + _ -> return ni + where + mkTrm t = case t of + Example (P _ cat) s -> parse cat s t + Example (Vr cat) s -> parse cat s t + _ -> composOp mkTrm t + parse cat s t = case parser (prt_ cat) s of + (tr:[], _) -> do + updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++) + return $ stripTerm tr + (tr:trs,_) -> do + updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++) + return $ stripTerm tr + ([],ms) -> do + updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++) + return t + morph s = case [w | w <- words s, not (morpho w)] of + [] -> "" + ws -> "unknown words: " ++ unwords ws diff --git a/src-3.0/GF/Compile/MkResource.hs b/src-3.0/GF/Compile/MkResource.hs new file mode 100644 index 000000000..10831b5c6 --- /dev/null +++ b/src-3.0/GF/Compile/MkResource.hs @@ -0,0 +1,128 @@ +---------------------------------------------------------------------- +-- | +-- Module : MkResource +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 21:08:14 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.14 $ +-- +-- Compile a gfc module into a "reuse" gfr resource, interface, or instance. +----------------------------------------------------------------------------- + +module GF.Compile.MkResource (makeReuse) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Grammar.Macros +import GF.Grammar.Lockfield +import GF.Grammar.PrGrammar + +import GF.Data.Operations + +import Control.Monad + +-- | extracting resource r from abstract + concrete syntax. +-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules +makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> + MReuseType Ident -> Err SourceRes +makeReuse gr r me mrc = do + flags <- return [] --- no flags are passed: they would not make sense + case mrc of + MRResource c -> do + (ops,jms) <- mkFull True c + return $ Module MTResource MSComplete flags me ops jms + + MRInstance c a -> do + (ops,jms) <- mkFull False c + return $ Module (MTInstance a) MSComplete flags me ops jms + + MRInterface c -> do + mc <- lookupModule gr c + + (ops,jms) <- case mc of + ModMod m -> case mtype m of + MTAbstract -> liftM ((,) (opens m)) $ + mkResDefs True False gr r c me + (extend m) (jments m) emptyBinTree + _ -> prtBad "expected abstract to be the type of" c + _ -> prtBad "expected abstract to be the type of" c + + return $ Module MTInterface MSIncomplete flags me ops jms + + where + mkFull hasT c = do + mc <- lookupModule gr c + + case mc of + ModMod m -> case mtype m of + MTConcrete a -> do + ma <- lookupModule gr a + jmsA <- case ma of + ModMod m' -> return $ jments m' + _ -> prtBad "expected abstract to be the type of" a + liftM ((,) (opens m)) $ + mkResDefs hasT True gr r a me (extend m) jmsA (jments m) + _ -> prtBad "expected concrete to be the type of" c + _ -> prtBad "expected concrete to be the type of" c + + +-- | the first Boolean indicates if the type needs be given +-- the second Boolean indicates if the definition needs be given +mkResDefs :: Bool -> Bool -> + SourceGrammar -> Ident -> Ident -> + [(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] -> + BinTree Ident Info -> BinTree Ident Info -> + Err (BinTree Ident Info) +mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where + + ifTyped = yes --- if hasT then yes else const nope --- needed for TC + ifCompl = if isC then yes else const nope + doIf b t = if b then t else return typeType -- latter value not used + + mkOne a mae (f,info) = case info of + AbsCat _ _ -> do + typ <- doIf isC $ err (const (return defLinType)) return $ look cnc f + typ' <- doIf isC $ lockRecType f typ + return (f, ResOper (ifTyped typeType) (ifCompl typ')) + AbsFun (Yes typ0) _ -> do + trm <- doIf isC $ look cnc f + testErr (not (isHardType typ0)) + ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0) + typ <- redirTyp True a mae typ0 + cat <- valCat typ + trm' <- doIf isC $ unlockRecord (snd cat) trm + return (f, ResOper (ifTyped typ) (ifCompl trm')) + AnyInd b n -> do + mo <- lookupModMod gr n + info' <- lookupInfo mo f + mkOne n (extend mo) (f,info') + + look cnc f = do + info <- lookupTree prt f cnc + case info of + CncCat (Yes ty) _ _ -> return ty + CncCat _ _ _ -> return defLinType + CncFun _ (Yes tr) _ -> return tr + AnyInd _ n -> do + mo <- lookupModMod gr n + t <- look (jments mo) f + redirTyp False n (extend mo) t + _ -> prtBad "not enough information to reuse" f + + -- type constant qualifications changed from abstract to resource + redirTyp always a mae ty = case ty of + Q _ c | always -> return $ Q r c + Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts + _ -> composOp (redirTyp always a mae) ty + +-- | no reuse for functions of HO\/dep types +isHardType t = case t of + Prod x a b -> not (isWild x) || isHardType a || isHardType b + App _ _ -> True + _ -> False + where + isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon diff --git a/src-3.0/GF/Compile/MkUnion.hs b/src-3.0/GF/Compile/MkUnion.hs new file mode 100644 index 000000000..b4b1f40c8 --- /dev/null +++ b/src-3.0/GF/Compile/MkUnion.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------- +-- | +-- Module : MkUnion +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:39 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.7 $ +-- +-- building union of modules. +-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance +----------------------------------------------------------------------------- + +module GF.Compile.MkUnion (makeUnion) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Grammar.Macros +import GF.Grammar.PrGrammar + +import GF.Data.Operations +import GF.Infra.Option + +import Data.List +import Control.Monad + +makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] -> + Err SourceModule +makeUnion gr m ty imps = do + ms <- mapM (lookupModMod gr . fst) imps + typ <- return ty ---- getTyp ms + ext <- getExt [i | Just i <- map extends ms] + ops <- return $ nub $ concatMap opens ms + flags <- return $ concatMap flags ms + js <- liftM (buildTree . concat) $ mapM getJments imps + return $ (m, ModMod (Module typ MSComplete flags ext ops js)) + + where + getExt es = case es of + [] -> return Nothing + i:is -> if all (==i) is then return (Just i) + else Bad "different extended modules in union forbidden" + getJments (i,fs) = do + m <- lookupModMod gr i + let js = jments m + if null fs + then + return (map (unqual i) $ tree2list js) + else do + ds <- mapM (flip justLookupTree js) fs + return $ map (unqual i) $ zip fs ds + + unqual i (f,d) = curry id f $ case d of + AbsCat pty pts -> AbsCat (qualCo pty) (qualPs pts) + AbsFun pty pt -> AbsFun (qualP pty) (qualP pt) + AbsTrans t -> AbsTrans $ qual t + ResOper pty pt -> ResOper (qualP pty) (qualP pt) + CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp) + CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp + ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) + ResValue pty -> ResValue (qualP pty) + _ -> d + where + qualP pt = case pt of + Yes t -> yes $ qual t + _ -> pt + qualPs pt = case pt of + Yes ts -> yes $ map qual ts + _ -> pt + qualCo pco = case pco of + Yes co -> yes $ [(x,qual t) | (x,t) <- co] + _ -> pco + qual t = case t of + Q m c | m==i -> Cn c + QC m c | m==i -> Cn c + _ -> composSafeOp qual t + qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co]) + qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t))) + qualLin Nothing = Nothing + diff --git a/src-3.0/GF/Compile/ModDeps.hs b/src-3.0/GF/Compile/ModDeps.hs new file mode 100644 index 000000000..8331057d1 --- /dev/null +++ b/src-3.0/GF/Compile/ModDeps.hs @@ -0,0 +1,153 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/NewRename.hs b/src-3.0/GF/Compile/NewRename.hs new file mode 100644 index 000000000..cec8ed24f --- /dev/null +++ b/src-3.0/GF/Compile/NewRename.hs @@ -0,0 +1,294 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:41 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- AR 14\/5\/2003 +-- +-- The top-level function 'renameGrammar' does several things: +-- +-- - extends each module symbol table by indirections to extended module +-- +-- - changes unqualified and as-qualified imports to absolutely qualified +-- +-- - goes through the definitions and resolves names +-- +-- Dependency analysis between modules has been performed before this pass. +-- Hence we can proceed by @fold@ing "from left to right". +----------------------------------------------------------------------------- + +module GF.Compile.NewRename (renameSourceTerm, renameModule) where + +import GF.Grammar.Grammar +import GF.Grammar.Values +import GF.Infra.Modules +import GF.Infra.Ident +import GF.Grammar.Macros +import GF.Grammar.PrGrammar +import GF.Grammar.AppPredefined +import GF.Grammar.Lookup +import GF.Compile.Extend +import GF.Data.Operations + +import Control.Monad + +-- | this gives top-level access to renaming term input in the cc command +renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term +renameSourceTerm g m t = do + mo <- lookupErr m (modules g) + let status = (modules g,(m,mo)) --- <- buildStatus g m mo + renameTerm status [] t + +-- | this is used in the compiler, separately for each module +renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] +renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of + ModMod m@(Module mt st fs me ops js) -> do + let js1 = jments m + let status = (ms, (name, mod)) + js2 <- mapMTree (renameInfo status) js1 + let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2 + return $ (name,mod2) : ms + +type Status = ([SourceModule],SourceModule) --- (StatusTree, [(OpenSpec Ident, StatusTree)]) + +--- type StatusTree = BinTree (Ident,StatusInfo) + +--- type StatusInfo = Ident -> Term + +lookupStatusInfo :: Ident -> SourceModule -> Err Term +lookupStatusInfo c (q,ModMod m) = do + i <- lookupTree prt c $ jments m + return $ case i of + AbsFun _ (Yes EData) -> QC q c + ResValue _ -> QC q c + ResParam _ -> QC q c + AnyInd True n -> QC n c --- should go further? + AnyInd False n -> Q n c + _ -> Q q c +lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q + +lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term +lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of + Ok v -> return v + _ -> lookupStatusInfoMany ms c +lookupStatusInfoMany [] x = + prtBad "renaming failed to find unqualified constant" x +---- should also give error if stg is found in more than one module + +renameIdentTerm :: Status -> Term -> Err Term +renameIdentTerm env@(imps,act@(_,ModMod this)) t = + errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $ + case t of + Vr c -> do + f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c + return $ f + Cn c -> do + f <- lookupStatusInfoMany openeds c + return $ f + Q m' c | m' == cPredef {- && isInPredefined c -} -> return t + Q m' c -> do + m <- lookupErr m' qualifs + f <- lookupStatusInfo c m + return $ f + QC m' c | m' == cPredef {- && isInPredefined c -} -> return t + QC m' c -> do + m <- lookupErr m' qualifs + f <- lookupStatusInfo c m + return $ f + _ -> return t + where + openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]] + qualifs = + [(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]] + ++ + [(m, (m,st)) | OSimple _ m <- opens this, Just st <- [lookup m imps]] + -- qualif is always possible + + -- this facility is mainly for BWC with GF1: you need not import PredefAbs + predefAbs c s = case c of + IC "Int" -> return $ Q cPredefAbs cInt + IC "String" -> return $ Q cPredefAbs cString + _ -> Bad s + +-- | would it make sense to optimize this by inlining? +renameIdentPatt :: Status -> Patt -> Err Patt +renameIdentPatt env p = do + let t = patt2term p + t' <- renameIdentTerm env t + term2patt t' + +{- deprec ! +info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) +info2status mq (c,i) = (c, case i of + AbsFun _ (Yes EData) -> maybe Con QC mq + ResValue _ -> maybe Con QC mq + ResParam _ -> maybe Con QC mq + AnyInd True m -> maybe Con (const (QC m)) mq + AnyInd False m -> maybe Cn (const (Q m)) mq + _ -> maybe Cn Q mq + ) + +tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo) +tree2status o = case o of + OSimple _ i -> mapTree (info2status (Just i)) + OQualif _ i j -> mapTree (info2status (Just j)) + +buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status +buildStatus gr c mo = let mo' = self2status c mo in case mo of + ModMod m -> do + let gr1 = MGrammar $ (c,mo) : modules gr + ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m + mods <- mapM (lookupModule gr1 . openedModule) ops + let sts = map modInfo2status $ zip ops mods + return $ if isModCnc m + then (NT, reverse sts) -- the module itself does not define any names + else (mo',reverse sts) -- so the empty ident is not needed + +modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) +modInfo2status (o,i) = (o,case i of + ModMod m -> tree2status o (jments m) + ) + +self2status :: Ident -> SourceModInfo -> StatusTree +self2status c i = mapTree (info2status (Just c)) js where -- qualify internal + js = case i of + ModMod m + | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m + | otherwise -> jments m + noTrans (_,d) = case d of -- to enable other than transfer js in transfer module + AbsTrans _ -> False + _ -> True +-} + +forceQualif o = case o of + OSimple q i -> OQualif q i i + OQualif q _ i -> OQualif q i i + +renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) +renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ + liftM ((,) i) $ case info of + AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) + (renPerh (mapM rent) pfs) + AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) + AbsTrans f -> liftM AbsTrans (rent f) + + ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) + ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp) + ResValue t -> liftM ResValue (ren t) + CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) + CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) + _ -> return info + where + ren = renPerh rent + rent = renameTerm status [] + +renPerh ren pt = case pt of + Yes t -> liftM Yes $ ren t + _ -> return pt + +renameTerm :: Status -> [Ident] -> Term -> Err Term +renameTerm env vars = ren vars where + ren vs trm = case trm of + Abs x b -> liftM (Abs x) (ren (x:vs) b) + Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) + Typed a b -> liftM2 Typed (ren vs a) (ren vs b) + Vr x + | elem x vs -> return trm + | otherwise -> renid trm + Cn _ -> renid trm + Con _ -> renid trm + Q _ _ -> renid trm + QC _ _ -> renid trm + Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs + T i cs -> do + i' <- case i of + TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source + _ -> return i + liftM (T i') $ mapM (renCase vs) cs + + Let (x,(m,a)) b -> do + m' <- case m of + Just ty -> liftM Just $ ren vs ty + _ -> return m + a' <- ren vs a + b' <- ren (x:vs) b + return $ Let (x,(m',a')) b' + + P t@(Vr r) l -- for constant t we know it is projection + | elem r vs -> return trm -- var proj first + | otherwise -> case renid (Q r (label2ident l)) of -- qualif second + Ok t -> return t + _ -> liftM (flip P l) $ renid t -- const proj last + + _ -> composOp (ren vs) trm + + renid = renameIdentTerm env + renCase vs (p,t) = do + (p',vs') <- renpatt p + t' <- ren (vs' ++ vs) t + return (p',t') + renpatt = renamePattern env + +-- | vars not needed in env, since patterns always overshadow old vars +renamePattern :: Status -> Patt -> Err (Patt,[Ident]) +renamePattern env patt = case patt of + + PC c ps -> do + c' <- renameIdentTerm env $ Cn c + psvss <- mapM renp ps + let (ps',vs) = unzip psvss + case c' of + QC p d -> return (PP p d ps', concat vs) + Q p d -> return (PP p d ps', concat vs) ---- should not happen + _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) + +---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps + + PV x -> case renid patt of + Ok p -> return (p,[]) + _ -> return (patt, [x]) + + PR r -> do + let (ls,ps) = unzip r + psvss <- mapM renp ps + let (ps',vs') = unzip psvss + return (PR (zip ls ps'), concat vs') + + _ -> return (patt,[]) + + where + renp = renamePattern env + renid = renameIdentPatt env + +renameParam :: Status -> (Ident, Context) -> Err (Ident, Context) +renameParam env (c,co) = do + co' <- renameContext env co + return (c,co') + +renameContext :: Status -> Context -> Err Context +renameContext b = renc [] where + renc vs cont = case cont of + (x,t) : xts + | isWildIdent x -> do + t' <- ren vs t + xts' <- renc vs xts + return $ (x,t') : xts' + | otherwise -> do + t' <- ren vs t + let vs' = x:vs + xts' <- renc vs' xts + return $ (x,t') : xts' + _ -> return cont + ren = renameTerm b + +-- | vars not needed in env, since patterns always overshadow old vars +renameEquation :: Status -> [Ident] -> Equation -> Err Equation +renameEquation b vs (ps,t) = do + (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps + t' <- renameTerm b (concat vs' ++ vs) t + return (ps',t') diff --git a/src-3.0/GF/Compile/NoParse.hs b/src-3.0/GF/Compile/NoParse.hs new file mode 100644 index 000000000..c8f828970 --- /dev/null +++ b/src-3.0/GF/Compile/NoParse.hs @@ -0,0 +1,49 @@ +---------------------------------------------------------------------- +-- | +-- Module : NoParse +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:41 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.1 $ +-- +-- Probabilistic abstract syntax. AR 30\/10\/2005 +-- +-- (c) Aarne Ranta 2005 under GNU GPL +-- +-- Contents: decide what lin rules no parser is generated. +-- Usually a list of noparse idents from 'i -boparse=file'. + +----------------------------------------------------------------------------- + +module GF.Compile.NoParse ( + NoParse -- = Ident -> Bool + ,getNoparseFromFile -- :: Opts -> IO NoParse + ,doParseAll -- :: NoParse + ) where + +import GF.Infra.Ident +import GF.Data.Operations +import GF.Infra.Option + + +type NoParse = (Ident -> Bool) + +doParseAll :: NoParse +doParseAll = const False + +getNoparseFromFile :: Options -> FilePath -> IO NoParse +getNoparseFromFile opts file = do + let f = maybe file id $ getOptVal opts noparseFile + s <- readFile f + let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s + tree `seq` return $ igns tree + where + igns tree i = isInBinTree i tree + +-- where +getIgnores s = case dropWhile (/="--#") (words s) of + _:"noparse":fs -> map identC fs + _ -> [] diff --git a/src-3.0/GF/Compile/Optimize.hs b/src-3.0/GF/Compile/Optimize.hs new file mode 100644 index 000000000..a540ee715 --- /dev/null +++ b/src-3.0/GF/Compile/Optimize.hs @@ -0,0 +1,300 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/PGrammar.hs b/src-3.0/GF/Compile/PGrammar.hs new file mode 100644 index 000000000..521f616b5 --- /dev/null +++ b/src-3.0/GF/Compile/PGrammar.hs @@ -0,0 +1,77 @@ +---------------------------------------------------------------------- +-- | +-- Module : PGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/25 10:27:12 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Compile.PGrammar (pTerm, pTrm, pTrms, + pMeta, pzIdent, + string2ident + ) where + +---import LexGF +import GF.Source.ParGF +import GF.Source.SourceToGrammar (transExp) +import GF.Grammar.Grammar +import GF.Infra.Ident +import qualified GF.Canon.AbsGFC as A +import qualified GF.Canon.GFC as G +import GF.Compile.GetGrammar +import GF.Grammar.Macros +import GF.Grammar.MMacros + +import GF.Data.Operations +import qualified Data.ByteString.Char8 as BS + +pTerm :: String -> Err Term +pTerm s = do + e <- pExp $ myLexer (BS.pack s) + transExp e + +pTrm :: String -> Term +pTrm = errVal (vr (zIdent "x")) . pTerm --- + +pTrms :: String -> [Term] +pTrms = map pTrm . sep [] where + sep t cs = case cs of + ',' : cs2 -> reverse t : sep [] cs2 + c : cs2 -> sep (c:t) cs2 + _ -> [reverse t] + +pTrm' :: String -> [Term] +pTrm' = err (const []) singleton . pTerm + +pMeta :: String -> Integer +pMeta _ = 0 --- + +pzIdent :: String -> Ident +pzIdent = zIdent + +{- +string2formsAndTerm :: String -> ([Term],Term) +string2formsAndTerm s = case s of + '[':_:_ -> case span (/=']') s of + (x,_:y) -> (pTrms (tail x), pTrm y) + _ -> ([],pTrm s) + _ -> ([], pTrm s) +-} + +string2ident :: String -> Err Ident +string2ident s = return $ string2var s + +{- +-- reads the Haskell datatype +readGrammar :: String -> Err GrammarST +readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> Bad "no parse of Grammar" + _ -> Bad "ambiguous parse of Grammar" +-} diff --git a/src-3.0/GF/Compile/PrOld.hs b/src-3.0/GF/Compile/PrOld.hs new file mode 100644 index 000000000..29920fab6 --- /dev/null +++ b/src-3.0/GF/Compile/PrOld.hs @@ -0,0 +1,84 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrOld +-- Maintainer : GF +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:44 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- a hack to print gf2 into gf1 readable files +-- Works only for canonical grammars, printed into GFC. Otherwise we would have +-- problems with qualified names. +-- --- printnames are not preserved, nor are lindefs +----------------------------------------------------------------------------- + +module GF.Compile.PrOld (printGrammarOld, stripTerm) where + +import GF.Grammar.PrGrammar +import GF.Canon.CanonToGrammar +import qualified GF.Canon.GFC as GFC +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Grammar.Macros +import GF.Infra.Modules +import qualified GF.Source.PrintGF as P +import GF.Source.GrammarToSource + +import Data.List +import GF.Data.Operations +import GF.Infra.UseIO + +printGrammarOld :: GFC.CanonGrammar -> String +printGrammarOld gr = err id id $ do + as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m] + cs0 <- mapM canon2sourceModule + [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m] + as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0 + cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0 + return $ unlines $ map prj $ srt as1 ++ srt cs1 + where + js (ModMod m) = jments m + srt = sortBy (\ (i,_) (j,_) -> compare i j) + prj ii = P.printTree $ trAnyDef ii + +stripInfo :: (Ident,Info) -> [(Ident,Info)] +stripInfo (c,i) = case i of + AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope + AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr)) + AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope + ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing)) + CncCat (Yes ty) _ _ -> rc $ + CncCat (Yes (stripTerm ty)) nope nope + CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope + _ -> [] + where + rc j = [(c,j)] + +stripContext co = [(x, stripTerm t) | (x,t) <- co] + +stripTerm :: Term -> Term +stripTerm t = case t of + Q _ c -> Vr c + QC _ c -> Vr c + T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where + ti' = case ti of + TTyped ty -> TTyped $ stripTerm ty + TComp ty -> TComp $ stripTerm ty + TWild ty -> TWild $ stripTerm ty + _ -> ti +---- R [] -> EInt 8 --- GF 1.2 parser doesn't accept empty records +---- RecType [] -> Cn (zIdent "Int") --- + _ -> composSafeOp stripTerm t + +stripPattern p = case p of + PC c [] -> PV c + PP _ c [] -> PV c + PC c ps -> PC c (map stripPattern ps) + PP _ c ps -> PC c (map stripPattern ps) + PR lps -> PR [(l, stripPattern p) | (l,p) <- lps] + PT t p -> PT (stripTerm t) (stripPattern p) + _ -> p + diff --git a/src-3.0/GF/Compile/Rebuild.hs b/src-3.0/GF/Compile/Rebuild.hs new file mode 100644 index 000000000..152983b96 --- /dev/null +++ b/src-3.0/GF/Compile/Rebuild.hs @@ -0,0 +1,99 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/RemoveLiT.hs b/src-3.0/GF/Compile/RemoveLiT.hs new file mode 100644 index 000000000..28aae9b84 --- /dev/null +++ b/src-3.0/GF/Compile/RemoveLiT.hs @@ -0,0 +1,63 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/Rename.hs b/src-3.0/GF/Compile/Rename.hs new file mode 100644 index 000000000..c3fef557b --- /dev/null +++ b/src-3.0/GF/Compile/Rename.hs @@ -0,0 +1,338 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/ShellState.hs b/src-3.0/GF/Compile/ShellState.hs new file mode 100644 index 000000000..0e24da601 --- /dev/null +++ b/src-3.0/GF/Compile/ShellState.hs @@ -0,0 +1,568 @@ +---------------------------------------------------------------------- +-- | +-- Module : ShellState +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:41 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.53 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Compile.ShellState where + +import GF.Data.Operations +import GF.Canon.GFC +import GF.Canon.AbsGFC +import GF.GFCC.CId +--import GF.GFCC.DataGFCC(mkGFCC) +import GF.GFCC.Macros (lookFCFG) +import GF.Canon.CanonToGFCC +import GF.Grammar.Macros +import GF.Grammar.MMacros + +import GF.Canon.Look +import GF.Canon.Subexpressions +import GF.Grammar.LookAbs +import GF.Compile.ModDeps +import GF.Compile.Evaluate +import qualified GF.Infra.Modules as M +import qualified GF.Grammar.Grammar as G +import qualified GF.Grammar.PrGrammar as P +import GF.CF.CF +import GF.CF.CFIdent +import GF.CF.CanonToCF +import GF.UseGrammar.Morphology +import GF.Probabilistic.Probabilistic +import GF.Compile.NoParse +import GF.Infra.Option +import GF.Infra.Ident +import GF.Infra.UseIO (justModuleName) +import GF.System.Arch (ModTime) + +import qualified Transfer.InterpreterAPI as T + +import GF.Formalism.FCFG +import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE +import qualified GF.Conversion.GFC as Cnv +import qualified GF.Conversion.SimpleToFCFG as FCnv +import qualified GF.Parsing.GFC as Prs + +import Control.Monad (mplus) +import Data.List (nub,nubBy) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) + + +-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished + +-- | multilingual state with grammars and options +data ShellState = ShSt { + abstract :: Maybe Ident , -- ^ pointer to actual abstract, if not empty st + concrete :: Maybe Ident , -- ^ pointer to primary concrete + concretes :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active + canModules :: CanonGrammar , -- ^ compiled abstracts and concretes + srcModules :: G.SourceGrammar , -- ^ saved resource modules + cfs :: [(Ident,CF)] , -- ^ context-free grammars (small, no parameters, very over-generating) + abstracts :: [(Ident,[Ident])], -- ^ abstracts and their associated concretes + mcfgs :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3) + fcfgs :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov + cfgs :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg + -- (large, with parameters, no-so overgenerating) + pInfos :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars) + morphos :: [(Ident,Morpho)], -- ^ morphologies + treebanks :: [(Ident,Treebank)], -- ^ treebanks + probss :: [(Ident,Probs)], -- ^ probability distributions + gloptions :: Options, -- ^ global options + readFiles :: [(String,(FilePath,ModTime))],-- ^ files read + absCats :: [(G.Cat,(G.Context, + [(G.Fun,G.Type)], + [((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts, + -- functions to them, + -- functions on them) + statistics :: [Statistics], -- ^ statistics on grammars + transfers :: [(Ident,T.Env)], -- ^ transfer modules + evalEnv :: EEnv -- ^ evaluation environment + } + +type Treebank = Map.Map String [String] -- string, trees + +actualConcretes :: ShellState -> [((Ident,Ident),Bool)] +actualConcretes sh = nub [((c,c),b) | + Just a <- [abstract sh], + ((c,_),_) <- concretes sh, ----concretesOfAbstract sh a, + let b = True ----- + ] + +concretesOfAbstract :: ShellState -> Ident -> [Ident] +concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs] + +data Statistics = + StDepTypes Bool -- ^ whether there are dependent types + | StBoundVars [G.Cat] -- ^ which categories have bound variables + --- -- etc + deriving (Eq,Ord) + +emptyShellState :: ShellState +emptyShellState = ShSt { + abstract = Nothing, + concrete = Nothing, + concretes = [], + canModules = M.emptyMGrammar, + srcModules = M.emptyMGrammar, + cfs = [], + abstracts = [], + mcfgs = [], + fcfgs = [], + cfgs = [], + pInfos = [], + morphos = [], + treebanks = [], + probss = [], + gloptions = noOptions, + readFiles = [], + absCats = [], + statistics = [], + transfers = [], + evalEnv = emptyEEnv + } + +optInitShellState :: Options -> ShellState +optInitShellState os = addGlobalOptions os emptyShellState + +type Language = Ident + +language :: String -> Language +language = identC + +prLanguage :: Language -> String +prLanguage = prIdent + +-- | grammar for one language in a state, comprising its abs and cnc +data StateGrammar = StGr { + absId :: Ident, + cncId :: Ident, + grammar :: CanonGrammar, + cf :: CF, + mcfg :: Cnv.MGrammar, + fcfg :: FGrammar, + cfg :: Cnv.CGrammar, + pInfo :: Prs.PInfo, + morpho :: Morpho, + probs :: Probs, + loptions :: Options + } + +emptyStateGrammar :: StateGrammar +emptyStateGrammar = StGr { + absId = identC "#EMPTY", --- + cncId = identC "#EMPTY", --- + grammar = M.emptyMGrammar, + cf = emptyCF, + mcfg = [], + fcfg = ([], Map.empty), + cfg = [], + pInfo = Prs.buildPInfo [] ([], Map.empty) [], + morpho = emptyMorpho, + probs = emptyProbs, + loptions = noOptions + } + +-- analysing shell grammar into parts + +stateGrammarST :: StateGrammar -> CanonGrammar +stateCF :: StateGrammar -> CF +stateMCFG :: StateGrammar -> Cnv.MGrammar +stateFCFG :: StateGrammar -> FGrammar +stateCFG :: StateGrammar -> Cnv.CGrammar +statePInfo :: StateGrammar -> Prs.PInfo +stateMorpho :: StateGrammar -> Morpho +stateProbs :: StateGrammar -> Probs +stateOptions :: StateGrammar -> Options +stateGrammarWords :: StateGrammar -> [String] +stateGrammarLang :: StateGrammar -> (CanonGrammar, Ident) + +stateGrammarST = grammar +stateCF = cf +stateMCFG = mcfg +stateFCFG = fcfg +stateCFG = cfg +statePInfo = pInfo +stateMorpho = morpho +stateProbs = probs +stateOptions = loptions +stateGrammarWords = allMorphoWords . stateMorpho +stateGrammarLang st = (grammar st, cncId st) + +---- this should be computed at compile time and stored +stateHasHOAS :: StateGrammar -> Bool +stateHasHOAS = hasHOAS . stateGrammarST + +cncModuleIdST :: StateGrammar -> CanonGrammar +cncModuleIdST = stateGrammarST + +-- | form a shell state from a canonical grammar +grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState +grammar2shellState opts (gr,sgr) = + updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe? + +-- | update a shell state from a canonical grammar +updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState -> + ((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) -> + Err ShellState +updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do + let cgr0 = M.updateMGrammar (canModules sh) gr + + -- a0 = abstract of old state + -- a1 = abstract of compiled grammar + + let a0 = abstract sh + a1 <- return $ case mcnc of + Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc + _ -> M.greatestAbstract cgr0 + + -- abstr0 = a1 if it exists + + let (abstr0,isNew) = case (a0,a1) of + (Just a, Just b) | a /= b -> (a1, True) + (Nothing, Just _) -> (a1, True) + _ -> (a0, False) + + let concrs0 = maybe [] (M.allConcretes cgr0) abstr0 + + let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ + maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh + + let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0) + purge = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo))) + + let cgr = M.MGrammar $ purge $ M.modules cgr0 + + let oldConcrs = map (snd . fst) (concretes sh) + newConcrs = maybe [] (M.allConcretes gr) abstr0 + toRetain (c,v) = notElem c newConcrs + let complete m = case M.lookupModule gr m of + Ok mo -> not $ isIncompleteCanon (m,mo) + _ -> False + + let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs + concr0 = ifNull Nothing (return . head) concrs + notInrts f = notElem f $ map fst rts + subcgr = unSubelimCanon cgr + cf's0 <- if (not (oElem (iOpt "docf") opts) && -- cf only built with -docf + (oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf + then return $ map snd $ cfs sh + else mapM (canon2cf opts ign subcgr) newConcrs + let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh) + + let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh) + let probss = [] ----- + + + let fromGFC = snd . snd . Cnv.convertGFC opts + (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs + gfcc = canon2gfcc opts cgr ---- UTF8 + fcfgs = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]] + pInfos = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs + + let funs = funRulesOf cgr + let cats = allCatsOf cgr + let csi = [(c,(co, + [(fun,typ) | (fun,typ) <- funs, compatType tc typ], + funsOnTypeFs compatType funs tc)) + | (c,co) <- cats, let tc = cat2val co c] + let deps = True ---- not $ null $ allDepCats cgr + let binds = [] ---- allCatsWithBind cgr + let src = M.updateMGrammar (srcModules sh) sgr + + return $ ShSt { + abstract = abstr0, + concrete = concr0, + concretes = zip (zip concrs concrs) (repeat True), + canModules = cgr, + srcModules = src, + cfs = cf's, + abstracts = maybe [] (\a -> [(a,concrs)]) abstr0, + mcfgs = zip concrs mcfgs, + fcfgs = fcfgs, + cfgs = zip concrs cfgs, + pInfos = zip concrs pInfos, + morphos = morphs, + treebanks = treebanks sh, + probss = zip concrs probss, + gloptions = gloptions sh, --- opts, -- this would be command-line options + readFiles = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts, + absCats = csi, + statistics = [StDepTypes deps,StBoundVars binds], + transfers = transfers sh, + evalEnv = eenv + } + +prShellStateInfo :: ShellState -> String +prShellStateInfo sh = unlines [ + "main abstract : " +++ abstractName sh, + "main concrete : " +++ maybe "(none)" P.prt (concrete sh), + "actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)), + "all abstracts : " +++ unwords (map (P.prt . fst) (abstracts sh)), + "all concretes : " +++ unwords (map (P.prt . fst . fst) (concretes sh)), + "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))), + "source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))), + "global options : " +++ prOpts (gloptions sh), + "transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)), + "treebanks : " +++ unwords (map (P.prt . fst) (treebanks sh)) + ] + +abstractName :: ShellState -> String +abstractName sh = maybe "(none)" P.prt (abstract sh) + +-- | throw away those abstracts that are not needed --- could be more aggressive +filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar +filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where + ms = M.modules cgr + needed (i,_) = elem i needs + needs = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts] + dep i a = elem i (ext mse a) + mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]] + ext es a = case lookup a es of + Just e -> a : concatMap (ext es) e ---- FIX multiple exts + _ -> [] + +purgeShellState :: ShellState -> ShellState +purgeShellState sh = ShSt { + abstract = abstr, + concrete = concrete sh, + concretes = concrs, + canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh, + srcModules = M.emptyMGrammar, + cfs = cfs sh, + abstracts = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr, + mcfgs = mcfgs sh, + fcfgs = fcfgs sh, + cfgs = cfgs sh, + pInfos = pInfos sh, + morphos = morphos sh, + treebanks = treebanks sh, + probss = probss sh, + gloptions = gloptions sh, + readFiles = [], + absCats = absCats sh, + statistics = statistics sh, + transfers = transfers sh, + evalEnv = emptyEEnv + } + where + abstr = abstract sh + concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed] + isSingle = length (abstracts sh) == 1 + needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs + purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) + acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh) + complete = not . isIncompleteCanon + +changeMain :: Maybe Ident -> ShellState -> Err ShellState +changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = + return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) +changeMain + (Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = + case lookup c (M.modules ms) of + Just _ -> do + a <- M.abstractOfConcrete ms c + let cas = M.allConcretes ms a + let cs' = [((c,c),True) | c <- cas] + return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs + pinfos mos tbs pbs os rs acs s trs ee) + _ -> P.prtBad "The state has no concrete syntax named" c + +-- | form just one state grammar, if unique, from a canonical grammar +grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar +grammar2stateGrammar opts gr = do + st <- grammar2shellState opts (gr,M.emptyMGrammar) + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +resourceOfShellState :: ShellState -> Maybe Ident +resourceOfShellState = M.greatestResource . srcModules + +qualifTop :: StateGrammar -> G.QIdent -> G.QIdent +qualifTop gr (_,c) = (absId gr,c) + +stateGrammarOfLang :: ShellState -> Language -> StateGrammar +stateGrammarOfLang = stateGrammarOfLangOpt True + +stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar +stateGrammarOfLangOpt purg st0 l = StGr { + absId = err (const (identC "Abs")) id $ M.abstractOfConcrete allCan l, --- + cncId = l, + grammar = allCan, + cf = maybe emptyCF id (lookup l (cfs st)), + mcfg = maybe [] id $ lookup l $ mcfgs st, + fcfg = maybe ([],Map.empty) id $ lookup l $ fcfgs st, + cfg = maybe [] id $ lookup l $ cfgs st, + pInfo = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st, + morpho = maybe emptyMorpho id (lookup l (morphos st)), + probs = maybe emptyProbs id (lookup l (probss st)), + loptions = errVal noOptions $ lookupOptionsCan allCan + } + where + st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0 + allCan = canModules st + +grammarOfLang :: ShellState -> Language -> CanonGrammar +cfOfLang :: ShellState -> Language -> CF +morphoOfLang :: ShellState -> Language -> Morpho +probsOfLang :: ShellState -> Language -> Probs +optionsOfLang :: ShellState -> Language -> Options + +grammarOfLang st = stateGrammarST . stateGrammarOfLang st +cfOfLang st = stateCF . stateGrammarOfLang st +morphoOfLang st = stateMorpho . stateGrammarOfLang st +probsOfLang st = stateProbs . stateGrammarOfLang st +optionsOfLang st = stateOptions . stateGrammarOfLang st + +removeLang :: Language -> ShellState -> ShellState +removeLang lang st = purgeShellState $ st{concretes = concs1} where + concs1 = filter ((/=lang) . snd . fst) $ concretes st + +-- | the last introduced grammar, stored in options, is the default for operations +firstStateGrammar :: ShellState -> StateGrammar +firstStateGrammar st = errVal (stateAbstractGrammar st) $ do + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +mkStateGrammar :: ShellState -> Language -> StateGrammar +mkStateGrammar = stateGrammarOfLang + +stateAbstractGrammar :: ShellState -> StateGrammar +stateAbstractGrammar st = StGr { + absId = maybe (identC "Abs") id (abstract st), --- + cncId = identC "#Cnc", --- + grammar = canModules st, ---- only abstarct ones + cf = emptyCF, + mcfg = [], + fcfg = ([],Map.empty), + cfg = [], + pInfo = Prs.buildPInfo [] ([],Map.empty) [], + morpho = emptyMorpho, + probs = emptyProbs, + loptions = gloptions st ---- + } + + +-- analysing shell state into parts + +globalOptions :: ShellState -> Options +allLanguages :: ShellState -> [Language] +allTransfers :: ShellState -> [Ident] +allCategories :: ShellState -> [G.Cat] +allStateGrammars :: ShellState -> [StateGrammar] +allStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)] +allGrammarFileNames :: ShellState -> [String] +allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)] +allActiveGrammars :: ShellState -> [StateGrammar] + +globalOptions = gloptions +--allLanguages = map (fst . fst) . concretes +allLanguages = map (snd . fst) . actualConcretes +allTransfers = map fst . transfers +allCategories = map fst . allCatsOf . canModules + +allStateGrammars = map snd . allStateGrammarsWithNames + +allStateGrammarsWithNames st = + [(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st] + +allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st] + +allActiveStateGrammarsWithNames st = + [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual + +allActiveGrammars = map snd . allActiveStateGrammarsWithNames + +pathOfModule :: ShellState -> Ident -> FilePath +pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh + +-- command-line option -lang=foo overrides the actual grammar in state +grammarOfOptState :: Options -> ShellState -> StateGrammar +grammarOfOptState opts st = + maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ + getOptVal opts useLanguage + +languageOfOptState :: Options -> ShellState -> Maybe Language +languageOfOptState opts st = + maybe (concrete st) (return . language) $ getOptVal opts useLanguage + +-- | command-line option -cat=foo overrides the possible start cat of a grammar +firstCatOpts :: Options -> StateGrammar -> CFCat +firstCatOpts opts sgr = + maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ + getOptVal opts firstCat + +-- | the first cat for random generation +firstAbsCat :: Options -> StateGrammar -> G.QIdent +firstAbsCat opts = cfCat2Cat . firstCatOpts opts + +-- | Gets the start category for the grammar from the options. +-- If the startcat is not set in the options, we look +-- for a flag in the grammar. If there is no flag in the +-- grammar, S is returned. +startCatStateOpts :: Options -> StateGrammar -> CFCat +startCatStateOpts opts sgr = + string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat)) + where optsStartCat = getOptVal opts gStartCat + grStartCat = getOptVal (stateOptions sgr) gStartCat + a = P.prt (absId sgr) + +-- | a grammar can have start category as option startcat=foo ; default is S +stateFirstCat :: StateGrammar -> CFCat +stateFirstCat = startCatStateOpts noOptions + +stateIsWord :: StateGrammar -> String -> Bool +stateIsWord sg = isKnownWord (stateMorpho sg) + +addProbs :: (Ident,Probs) -> ShellState -> Err ShellState +addProbs ip@(lang,probs) sh = do + let gr = grammarOfLang sh lang + probs' <- checkGrammarProbs gr probs + let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh) + return $ sh{probss = pbs'} + +addTransfer :: (Ident,T.Env) -> ShellState -> ShellState +addTransfer it@(i,_) sh = + sh {transfers = it : filter ((/= i) . fst) (transfers sh)} + +addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState +addTreebanks its sh = sh {treebanks = its ++ treebanks sh} + +findTreebank :: ShellState -> Ident -> Err Treebank +findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh + +-- modify state + +type ShellStateOper = ShellState -> ShellState +type ShellStateOperErr = ShellState -> Err ShellState + +reinitShellState :: ShellStateOper +reinitShellState = const emptyShellState + +languageOn, languageOff :: Language -> ShellStateOper +languageOn = languageOnOff True +languageOff = languageOnOff False + +languageOnOff :: Bool -> Language -> ShellStateOper +--- __________ this is OBSOLETE +languageOnOff b lang sh = sh {concretes = cs'} where + cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh] + +changeOptions :: (Options -> Options) -> ShellStateOper +--- __________ this is OBSOLETE +changeOptions f sh = sh {gloptions = f (gloptions sh)} + +addGlobalOptions :: Options -> ShellStateOper +addGlobalOptions = changeOptions . addOptions + +removeGlobalOptions :: Options -> ShellStateOper +removeGlobalOptions = changeOptions . removeOptions + diff --git a/src-3.0/GF/Compile/Update.hs b/src-3.0/GF/Compile/Update.hs new file mode 100644 index 000000000..82d7a609e --- /dev/null +++ b/src-3.0/GF/Compile/Update.hs @@ -0,0 +1,135 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Compile/Wordlist.hs b/src-3.0/GF/Compile/Wordlist.hs new file mode 100644 index 000000000..3fbc066bd --- /dev/null +++ b/src-3.0/GF/Compile/Wordlist.hs @@ -0,0 +1,108 @@ +---------------------------------------------------------------------- +-- | +-- Module : Wordlist +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: +-- > CVS $Author: +-- > CVS $Revision: +-- +-- Compile a gfwl file (multilingual word list) to an abstract + concretes +----------------------------------------------------------------------------- + +module GF.Compile.Wordlist (mkWordlist) where + +import GF.Data.Operations +import GF.Infra.UseIO +import Data.List +import Data.Char +import System.FilePath + +-- read File.gfwl, write File.gf (abstract) and a set of concretes +-- return the names of the concretes + +mkWordlist :: FilePath -> IO [FilePath] +mkWordlist file = do + s <- readFileIf file + let abs = dropExtension file + let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s + let (gr,grs) = mkGrammars abs cnchs wlist + let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs] + mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs + putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs) + return cncfs + +{- +-- syntax of files, e.g. + + # Svenska - Franska - Finska -- names of concretes + + berg - montagne - vuori -- word entry + +-- this creates: + + cat S ; + fun berg_S : S ; + lin berg_S = {s = ["berg"]} ; + lin berg_S = {s = ["montagne"]} ; + lin berg_S = {s = ["vuori"]} ; + +-- support for different categories to be elaborated. The syntax it + + Verb . klättra - grimper / escalader - kiivetä / kiipeillä + +-- notice that a word can have several alternative (separator /) +-- and that an alternative can consist of several words +-} + +type CncHeader = (String,String) -- module name, module header + +type Wordlist = [(String, [[String]])] -- cat, variants for each cnc + + +pWordlist :: String -> [String] -> ([CncHeader],Wordlist) +pWordlist abs ls = (headers,rules) where + (hs,rs) = span ((=="#") . take 1) ls + headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs + rules = map (mkRule . words) rs + + mkHeader ws = case ws of + w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2)) + mkRule ws = case ws of + cat:".":vs -> (cat, mkWords vs) + _ -> ("S", mkWords ws) + mkWords = map (map unwords . chunks "/") . chunks "-" + + +mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String]) +mkGrammars ab hs wl = (abs,cncs) where + abs = unlines $ map unwords $ + ["abstract",ab,"=","{"]: + cats ++ + funs ++ + [["}"]] + + cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss] + + cats = [["cat",c,";"] | c <- nub $ map fst wl] + funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf] + + wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl] + + rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]] + + lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"] + + val ss = case ss of + [w] -> quote w + _ -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}" + + quote w = "[" ++ prQuotedString w ++ "]" + + ident f c = concat $ intersperse "_" $ words (head f) ++ [c] + + +notComment s = not (all isSpace s) && take 2 s /= "--" + diff --git a/src-3.0/GF/Conversion/GFC.hs b/src-3.0/GF/Conversion/GFC.hs new file mode 100644 index 000000000..354bdea65 --- /dev/null +++ b/src-3.0/GF/Conversion/GFC.hs @@ -0,0 +1,157 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/01 09:53:18 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.14 $ +-- +-- All conversions from GFC +----------------------------------------------------------------------------- + +module GF.Conversion.GFC + (module GF.Conversion.GFC, + SGrammar, EGrammar, MGrammar, CGrammar) where + +import GF.Infra.Option +import GF.Canon.GFC (CanonGrammar) +import GF.Infra.Ident (Ident, identC) +import qualified GF.Infra.Modules as M + +import GF.Formalism.GCFG (Rule(..), Abstract(..)) +import GF.Formalism.SimpleGFC (decl2cat) +import GF.Formalism.CFG (CFRule(..)) +import GF.Formalism.Utilities (symbol, name2fun) +import GF.Conversion.Types + +import qualified GF.Conversion.GFCtoSimple as G2S +import qualified GF.Conversion.SimpleToFinite as S2Fin +import qualified GF.Conversion.RemoveSingletons as RemSing +import qualified GF.Conversion.RemoveErasing as RemEra +import qualified GF.Conversion.RemoveEpsilon as RemEps +import qualified GF.Conversion.SimpleToMCFG as S2M +import qualified GF.Conversion.MCFGtoCFG as M2C + +import GF.Infra.Print + +import GF.System.Tracing + +---------------------------------------------------------------------- +-- * GFC -> MCFG & CFG, using options to decide which conversion is used + +convertGFC :: Options -> (CanonGrammar, Ident) + -> (SGrammar, (EGrammar, (MGrammar, CGrammar))) +convertGFC opts = \g -> let s = g2s g + e = s2e s + m = e2m e + in trace2 "Options" (show opts) (s, (e, (m, e2c e))) + where e2c = M2C.convertGrammar + e2m = case getOptVal opts firstCat of + Just cat -> flip erasing [identC cat] + Nothing -> flip erasing [] + s2e = case getOptVal opts gfcConversion of + Just "strict" -> strict + Just "finite-strict" -> strict + Just "epsilon" -> epsilon . nondet + _ -> nondet + g2s = case getOptVal opts gfcConversion of + Just "finite" -> finite . simple + Just "finite2" -> finite . finite . simple + Just "finite3" -> finite . finite . finite . simple + Just "singletons" -> single . simple + Just "finite-singletons" -> single . finite . simple + Just "finite-strict" -> finite . simple + _ -> simple + + simple = G2S.convertGrammar + strict = S2M.convertGrammarStrict + nondet = S2M.convertGrammarNondet + epsilon = RemEps.convertGrammar + finite = S2Fin.convertGrammar + single = RemSing.convertGrammar + erasing = RemEra.convertGrammar + +gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar +gfc2simple opts = fst . convertGFC opts + +gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar +gfc2mcfg opts g = mcfg + where + (mcfg, _) = snd (snd (convertGFC opts g)) + +gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar +gfc2cfg opts g = cfg + where + (_, cfg) = snd (snd (convertGFC opts g)) + + +---------------------------------------------------------------------- +-- * single step conversions + +{- +gfc2simple :: (CanonGrammar, Ident) -> SGrammar +gfc2simple = G2S.convertGrammar + +simple2finite :: SGrammar -> SGrammar +simple2finite = S2Fin.convertGrammar + +removeSingletons :: SGrammar -> SGrammar +removeSingletons = RemSing.convertGrammar + +simple2mcfg_nondet :: SGrammar -> EGrammar +simple2mcfg_nondet = + +simple2mcfg_strict :: SGrammar -> EGrammar +simple2mcfg_strict = S2M.convertGrammarStrict + +mcfg2cfg :: EGrammar -> CGrammar +mcfg2cfg = M2C.convertGrammar + +removeErasing :: EGrammar -> [SCat] -> MGrammar +removeErasing = RemEra.convertGrammar + +removeEpsilon :: EGrammar -> EGrammar +removeEpsilon = RemEps.convertGrammar +-} + +---------------------------------------------------------------------- +-- * converting to some obscure formats + +gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun] +gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) | + Rule (Abs decl decls name) _ <- G2S.convertGrammar gr ] + +abstract2skvatt :: [Abstract SCat Fun] -> String +abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr + where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++ + "\"" ++ prt fun ++ "\".\n" + abs2pl (Abs cat cats fun) = + prtQuoted cat ++ " ---> " ++ + "\"(" ++ prt fun ++ "\"" ++ + prtBefore ", \" \", " (map prtQuoted cats) ++ ", \")\".\n" + +cfg2skvatt :: CGrammar -> String +cfg2skvatt gr = skvatt_hdr ++ concatMap cfg2pl gr + where cfg2pl (CFRule cat syms _name) = + prtQuoted cat ++ " ---> " ++ + if null syms then "\"\".\n" else + prtSep ", " (map (symbol prtQuoted prTok) syms) ++ ".\n" + prTok tok = "\"" ++ tok ++ " \"" + +skvatt_hdr = ":- use_module(library(skvatt)).\n" ++ + ":- use_module(library(utils), [repeat/1]).\n" ++ + "corpus(File, StartCat, Depth, Size) :- \n" ++ + " set_flag(gendepth, Depth),\n" ++ + " tell(File), repeat(Size),\n" ++ + " generate_words(StartCat, String), format('~s~n~n', [String]),\n" ++ + " write(user_error, '.'),\n" ++ + " fail ; told.\n\n" + +prtQuoted :: Print a => a -> String +prtQuoted a = "'" ++ prt a ++ "'" + + + + diff --git a/src-3.0/GF/Conversion/GFCtoSimple.hs b/src-3.0/GF/Conversion/GFCtoSimple.hs new file mode 100644 index 000000000..b6a34a8ce --- /dev/null +++ b/src-3.0/GF/Conversion/GFCtoSimple.hs @@ -0,0 +1,175 @@ +--------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/07 11:24:51 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.15 $ +-- +-- Converting GFC to SimpleGFC +-- +-- the conversion might fail if the GFC grammar has dependent or higher-order types, +-- or if the grammar contains bound pattern variables +-- (use -optimize=values/share/none when importing) +-- +-- TODO: lift all functions to the 'Err' monad +----------------------------------------------------------------------------- + +module GF.Conversion.GFCtoSimple + (convertGrammar) where + +import qualified GF.Canon.AbsGFC as A +import qualified GF.Infra.Ident as I +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Formalism.Utilities +import GF.Conversion.Types + +import GF.UseGrammar.Linear (expandLinTables) +import GF.Canon.GFC (CanonGrammar) +import GF.Canon.MkGFC (grammar2canon) +import GF.Canon.Subexpressions (unSubelimCanon) +import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat) +import qualified GF.Canon.CMacros as CMacros (defLinType) +import GF.Data.Operations (err, errVal) +--import qualified Modules as M + +import GF.System.Tracing +import GF.Infra.Print + +---------------------------------------------------------------------- + +type Env = (CanonGrammar, I.Ident) + +convertGrammar :: Env -> SGrammar +convertGrammar (g,i) = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $ + tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $ + [ convertAbsFun gram fun typing | + A.Mod (A.MTAbs modname) _ _ _ defs <- modules, + A.AbsDFun fun typing _ <- defs ] + where A.Gr modules = grammar2canon (fst gram) + gram = (unSubelimCanon g,i) + +convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule +convertAbsFun gram fun typing = -- trace2 "GFCtoSimple - converting function" (prt fun) $ + Rule abs cnc + where abs = convertAbstract [] fun typing + cnc = convertConcrete gram abs + +---------------------------------------------------------------------- +-- abstract definitions + +convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name +convertAbstract env fun (A.EProd x a b) + = convertAbstract (convertAbsType x' [] a : env) fun b + where x' = if x==I.identC "h_" then anyVar else x +convertAbstract env fun a + = Abs (convertAbsType anyVar [] a) (reverse env) name + where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ] + +convertAbsType :: Var -> [FOType SCat] -> A.Exp -> SDecl +convertAbsType x args (A.EProd _ a b) = convertAbsType x (convertType [] a : args) b +convertAbsType x args a = Decl x (reverse args ::--> convertType [] a) + +convertType :: [TTerm] -> A.Exp -> FOType SCat +convertType args (A.EApp a b) = convertType (convertExp [] b : args) a +convertType args (A.EAtom at) = convertCat at ::@ reverse args +convertType args (A.EProd _ _ b) = convertType args b ---- AR 7/10 workaround +convertType args exp = error $ "GFCtoSimple.convertType: " ++ prt exp + +{- Exp from GF/Canon/GFC.cf: +EApp. Exp1 ::= Exp1 Exp2 ; +EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ; +EAbs. Exp ::= "\\" Ident "->" Exp ; +EAtom. Exp2 ::= Atom ; +EData. Exp2 ::= "data" ; +-} + +convertExp :: [TTerm] -> A.Exp -> TTerm +convertExp args (A.EAtom at) = convertAtom args at +convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a +convertExp args exp = error $ "GFCtoSimple.convertExp: " ++ prt exp + +convertAtom :: [TTerm] -> A.Atom -> TTerm +convertAtom args (A.AC con) = con :@ reverse args +-- A.AD: is this correct??? +convertAtom args (A.AD con) = con :@ args +convertAtom [] (A.AV var) = TVar var +convertAtom args atom = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ show atom + +convertCat :: A.Atom -> SCat +convertCat (A.AC (A.CIQ _ cat)) = cat +convertCat atom = error $ "GFCtoSimple.convertCat: " ++ show atom + +---------------------------------------------------------------------- +-- concrete definitions + +convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm) +convertConcrete gram (Abs decl args name) = Cnc ltyp largs term + where term = fmap (convertTerm gram . expandTerm gram) $ lookupLin gram $ name2fun name + ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args) + +expandTerm :: Env -> A.Term -> A.Term +expandTerm gram term = -- tracePrt "expanded term" prt $ + err error id $ expandLinTables (fst gram) $ + -- tracePrt "initial term" prt $ + term + +convertCType :: Env -> A.CType -> SLinType +convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ] +convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt) +convertCType gram ct@(A.Cn con) = ConT $ map (convertTerm gram) $ groundTerms gram ct +convertCType gram (A.TStr) = StrT +convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor" + +convertTerm :: Env -> A.Term -> STerm +convertTerm gram (A.Arg arg) = convertArgVar arg +convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms +-- convertTerm gram (A.LI var) = Var var +convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ] +convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl +convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) | + (pat, term) <- zip (groundTerms gram ctype) terms ] +convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) | + A.Cas pats term <- tbl, pat <- pats ] +convertTerm gram (A.S term sel) = convertTerm gram term :! convertTerm gram sel +convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2 +convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms) +convertTerm gram (A.E) = Empty +convertTerm gram (A.K (A.KS tok)) = Token tok +-- 'pre' tokens are converted to variants (over-generating): +convertTerm gram (A.K (A.KP strs vars)) + = variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ] + where conc [] = Empty + conc ts = foldr1 (?++) $ map Token ts +convertTerm gram (A.I con) = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor" +convertTerm gram (A.EInt int) = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor" + +convertArgVar :: A.ArgVar -> STerm +convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath +convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath + +convertPatt (A.PC con pats) = con :^ map convertPatt pats +-- convertPatt (A.PV x) = Var x +-- convertPatt (A.PW) = Wildcard +convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ] +convertPatt (A.PI n) = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor" +convertPatt p = error $ "GFCtoSimple.convertPatt: cannot handle " ++ show p + +---------------------------------------------------------------------- + +lookupLin :: Env -> Fun -> Maybe A.Term +lookupLin gram fun = err fail Just $ + Look.lookupLin (fst gram) (A.CIQ (snd gram) fun) + +lookupCType :: Env -> SDecl -> A.CType +lookupCType env decl + = errVal CMacros.defLinType $ + Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl)) + +groundTerms :: Env -> A.CType -> [A.Term] +groundTerms gram ctype = err error id $ + Look.allParamValues (fst gram) ctype + diff --git a/src-3.0/GF/Conversion/Haskell.hs b/src-3.0/GF/Conversion/Haskell.hs new file mode 100644 index 000000000..abe651e1e --- /dev/null +++ b/src-3.0/GF/Conversion/Haskell.hs @@ -0,0 +1,71 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/11 14:11:46 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.1 $ +-- +-- Converting/Printing different grammar formalisms in Haskell-readable format +----------------------------------------------------------------------------- + + +module GF.Conversion.Haskell where + +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Formalism.MCFG +import GF.Formalism.CFG +import GF.Formalism.Utilities +import GF.Conversion.Types +import GF.Data.Operations ((++++), (+++++)) +import GF.Infra.Print + +import Data.List (intersperse) + +-- | SimpleGFC to Haskell +prtSGrammar :: SGrammar -> String +prtSGrammar rules = "-- Simple GFC grammar as a Haskell file" ++++ + "-- Autogenerated from the Grammatical Framework" +++++ + "import GF.Formalism.GCFG" ++++ + "import GF.Formalism.SimpleGFC" ++++ + "import GF.Formalism.Utilities" ++++ + "import GF.Canon.AbsGFC (CIdent(..), Label(..))" ++++ + "import GF.Infra.Ident (Ident(..))" +++++ + "grammar :: SimpleGrammar Ident (NameProfile Ident) String" ++++ + "grammar = \n\t[ " ++ + concat (intersperse "\n\t, " (map show rules)) ++ "\n\t]\n\n" + +-- | MCFG to Haskell +prtMGrammar :: MGrammar -> String +prtMGrammar rules = "-- Multiple context-free grammar as a Haskell file" ++++ + "-- Autogenerated from the Grammatical Framework" +++++ + "import GF.Formalism.GCFG" ++++ + "import GF.Formalism.MCFG" ++++ + "import GF.Formalism.Utilities" +++++ + "grammar :: MCFGrammar String (NameProfile String) String String" ++++ + "grammar = \n\t[ " ++ + concat (intersperse "\n\t, " (map prtMRule rules)) ++ "\n\t]\n\n" + where prtMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc lcat lcats lins)) + = show (Rule (Abs (prt cat) (map prt cats) (Name (prt fun) (map cnvProfile profiles))) + (Cnc (map prt lcat) (map (map prt) lcats) (map cnvLin lins))) + cnvLin (Lin lbl syms) = Lin (prt lbl) (map (mapSymbol prtMArg id) syms) + prtMArg (cat, lbl, nr) = (prt cat, prt lbl, nr) + +-- | CFG to Haskell +prtCGrammar :: CGrammar -> String +prtCGrammar rules = "-- Context-free grammar as a Haskell file" ++++ + "-- autogenerated from the Grammatical Framework" +++++ + "import GF.Formalism.CFG" ++++ + "import GF.Formalism.Utilities" ++++ + "\ngrammar :: CFGrammar String (NameProfile String) String" ++++ + "grammar = \n\t[ " ++ + concat (intersperse "\n\t, " (map prtCRule rules)) ++ "\n\t]\n\n" + where prtCRule (CFRule cat syms (Name fun profiles)) + = show (CFRule (prt cat) (map (mapSymbol prt id) syms) + (Name (prt fun) (map cnvProfile profiles))) + +cnvProfile (Unify args) = Unify args +cnvProfile (Constant forest) = Constant (fmap prt forest) diff --git a/src-3.0/GF/Conversion/MCFGtoCFG.hs b/src-3.0/GF/Conversion/MCFGtoCFG.hs new file mode 100644 index 000000000..a58c31d37 --- /dev/null +++ b/src-3.0/GF/Conversion/MCFGtoCFG.hs @@ -0,0 +1,53 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:43 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.6 $ +-- +-- Converting MCFG grammars to (possibly overgenerating) CFG +----------------------------------------------------------------------------- + + +module GF.Conversion.MCFGtoCFG + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import Control.Monad +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.CFG +import GF.Conversion.Types + +---------------------------------------------------------------------- +-- * converting (possibly erasing) MCFG grammars + +convertGrammar :: EGrammar -> CGrammar +convertGrammar gram = tracePrt "MCFGtoCFG - context-free rules" (prt.length) $ + concatMap convertRule gram + +convertRule :: ERule -> [CRule] +convertRule (Rule (Abs cat args (Name fun mprofile)) (Cnc _ _ record)) + = [ CFRule (CCat cat lbl) rhs (Name fun profile) | + Lin lbl lin <- record, + let rhs = map (mapSymbol convertArg id) lin, + let cprofile = map (Unify . argPlaces lin) [0 .. length args-1], + let profile = mprofile `composeProfiles` cprofile + ] + +convertArg :: (ECat, ELabel, Int) -> CCat +convertArg (cat, lbl, _) = CCat cat lbl + +argPlaces :: [Symbol (cat, lbl, Int) tok] -> Int -> [Int] +argPlaces lin nr = [ place | (nr', place) <- zip linArgs [0..], nr == nr' ] + where linArgs = [ nr' | (_, _, nr') <- filterCats lin ] + + + + diff --git a/src-3.0/GF/Conversion/MCFGtoFCFG.hs b/src-3.0/GF/Conversion/MCFGtoFCFG.hs new file mode 100644 index 000000000..70aa4644d --- /dev/null +++ b/src-3.0/GF/Conversion/MCFGtoFCFG.hs @@ -0,0 +1,51 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:43 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.6 $ +-- +-- Converting MCFG grammars to equivalent optimized FCFG +----------------------------------------------------------------------------- + + +module GF.Conversion.MCFGtoFCFG + (convertGrammar) where + +import Control.Monad +import List (elemIndex) +import Array + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.FCFG +import GF.Conversion.Types +import GF.Data.SortedList (nubsort) + +import GF.Infra.Print + +---------------------------------------------------------------------- +-- * converting MCFG to optimized FCFG + +convertGrammar :: MGrammar -> FGrammar +convertGrammar gram = [ FRule (Abs (fcat cat) (map fcat cats) name) (fcnc cnc) | + Rule (Abs cat cats name) cnc <- gram ] + where mcats = nubsort [ mc | Rule (Abs mcat mcats _) _ <- gram, mc <- mcat:mcats ] + + fcat mcat@(MCat (ECat scat ecns) mlbls) + = case elemIndex mcat mcats of + Just catid -> FCat catid scat mlbls ecns + Nothing -> error ("MCFGtoFCFG.fcat " ++ prt mcat) + + fcnc (Cnc _ arglbls lins) = listArray (0, length lins-1) (map flin lins) + where flin (Lin _ syms) = listArray (0, length syms-1) (map fsym syms) + fsym (Tok tok) = FSymTok tok + fsym (Cat (cat,lbl,arg)) = FSymCat (fcat cat) (flbl arg lbl) arg + flbl arg lbl = case elemIndex lbl (arglbls !! arg) of + Just lblid -> lblid + Nothing -> error ("MCFGtoFCFG.flbl " ++ prt arg ++ " " ++ prt lbl) + diff --git a/src-3.0/GF/Conversion/Prolog.hs b/src-3.0/GF/Conversion/Prolog.hs new file mode 100644 index 000000000..b930cb476 --- /dev/null +++ b/src-3.0/GF/Conversion/Prolog.hs @@ -0,0 +1,205 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/14 09:51:18 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.4 $ +-- +-- Converting/Printing different grammar formalisms in Prolog-readable format +----------------------------------------------------------------------------- + + +module GF.Conversion.Prolog (prtSGrammar, prtSMulti, prtSHeader, prtSRule, + prtMGrammar, prtMMulti, prtMHeader, prtMRule, + prtCGrammar, prtCMulti, prtCHeader, prtCRule) where + +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Formalism.MCFG +import GF.Formalism.CFG +import GF.Formalism.Utilities +import GF.Conversion.Types +import qualified GF.Conversion.GFC as Cnv + +import GF.Data.Operations ((++++), (+++++)) +import GF.Infra.Print +import qualified GF.Infra.Modules as Mod +import qualified GF.Infra.Option as Option +import GF.Data.Operations (okError) +import GF.Canon.AbsGFC (Flag(..)) +import GF.Canon.GFC (CanonGrammar) +import GF.Infra.Ident (Ident(..)) + +import Data.Maybe (maybeToList, listToMaybe) +import Data.Char (isLower, isAlphaNum) + +import GF.System.Tracing + +---------------------------------------------------------------------- +-- | printing multiple languages at the same time + +prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String +prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple "gfc_" +prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg "mcfg_" +prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg "cfg_" + +-- code and ideas stolen from GF.CFGM.PrintCFGrammar + +prtMulti prtHeader prtRule conversion prefix opts gr + = prtHeader ++++ unlines + [ "\n\n" ++ prtLine ++++ + "%% Language module: " ++ prtQ langmod +++++ + unlines (map (prtRule langmod) rules) | + lang <- maybe [] (Mod.allConcretes gr) (Mod.greatestAbstract gr), + let Mod.ModMod (Mod.Module{Mod.flags=fs}) = okError (Mod.lookupModule gr lang), + let cnvopts = Option.Opts $ map Option.gfcConversion $ getFlag fs "conversion", + let rules = conversion cnvopts (gr, lang), + let langmod = (let IC lg = lang in prefix ++ lg) ] + +getFlag :: [Flag] -> String -> [String] +getFlag fs x = [v | Flg (IC k) (IC v) <- fs, k == x] + +---------------------------------------------------------------------- +-- | SimpleGFC to Prolog +-- +-- assumes that the profiles in the Simple GFC names are trivial +prtSGrammar :: SGrammar -> String +prtSGrammar rules = prtSHeader +++++ unlines (map (prtSRule "") rules) + +prtSHeader :: String +prtSHeader = prtLine ++++ + "%% Simple GFC grammar in Prolog-readable format" ++++ + "%% Autogenerated from the Grammatical Framework" +++++ + "%% The following predicate is defined:" ++++ + "%% \t rule(Fun, Cat, c(Cat,...), LinTerm)" + +prtSRule :: String -> SRule -> String +prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm)) + = (if null lang then "" else prtQ lang ++ " : ") ++ + prtFunctor "rule" [plfun, plcat, plcats, plcnc] ++ "." + where plfun = prtQ fun + plcat = prtSDecl cat + plcats = prtFunctor "c" (map prtSDecl cats) + plcnc = "\n\t" ++ prtSTerm (maybe Empty id mterm) + +prtSTerm (Arg n c p) = prtFunctor "arg" [prtQ c, prt (n+1), prtSPath p] +-- prtSTerm (c :^ []) = prtQ c +prtSTerm (c :^ ts) = prtOper "^" (prtQ c) (prtPList (map prtSTerm ts)) +prtSTerm (Rec rec) = prtFunctor "rec" [prtPList [ prtOper "=" (prtQ l) (prtSTerm t) | (l, t) <- rec ]] +prtSTerm (Tbl tbl) = prtFunctor "tbl" [prtPList [ prtOper "=" (prtSTerm p) (prtSTerm t) | (p, t) <- tbl ]] +prtSTerm (Variants ts) = prtFunctor "variants" [prtPList (map prtSTerm ts)] +prtSTerm (t1 :++ t2) = prtOper "+" (prtSTerm t1) (prtSTerm t2) +prtSTerm (Token t) = prtFunctor "tok" [prtQ t] +prtSTerm (Empty) = "empty" +prtSTerm (term :. lbl) = prtOper "*" (prtSTerm term) (prtQ lbl) +prtSTerm (term :! sel) = prtOper "/" (prtSTerm term) (prtSTerm sel) +-- prtSTerm (Wildcard) = "wildcard" +-- prtSTerm (Var var) = prtFunctor "var" [prtQ var] + +prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path) + +prtSDecl (Decl var typ) | var == anyVar = prtSAbsType typ + | otherwise = "_" ++ prtVar var ++ ":" ++ prtSAbsType typ + + +prtSAbsType ([] ::--> typ) = prtSFOType typ +prtSAbsType (args ::--> typ) = prtOper ":->" (prtPList (map prtSFOType args)) (prtSFOType typ) + +prtSFOType (cat ::@ args) = prtFunctor (prtQ cat) (map prtSTTerm args) + +prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args) +prtSTTerm (TVar var) = "_" ++ prtVar var + +---------------------------------------------------------------------- +-- | MCFG to Prolog +prtMGrammar :: MGrammar -> String +prtMGrammar rules = prtMHeader +++++ unlines (map (prtMRule "") rules) + +prtMHeader :: String +prtMHeader = prtLine ++++ + "%% Multiple context-free grammar in Prolog-readable format" ++++ + "%% Autogenerated from the Grammatical Framework" +++++ + "%% The following predicate is defined:" ++++ + "%% \t rule(Profile, Cat, c(Cat,...), [Lbl=Symbols,...])" + +prtMRule :: String -> MRule -> String +prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins)) + = (if null lang then "" else prtQ lang ++ " : ") ++ + prtFunctor "rule" [plname, plcat, plcats, pllins] ++ "." + where plname = prtName name + plcat = prtQ cat + plcats = prtFunctor "c" (map prtQ cats) + pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]" + +prtMLin (Lin lbl lin) = prtOper "=" (prtQ lbl) (prtPList (map prtMSymbol lin)) + +prtMSymbol (Cat (cat, lbl, nr)) = prtFunctor "arg" [prtQ cat, show (nr+1), prtQ lbl] +prtMSymbol (Tok tok) = prtFunctor "tok" [prtQ tok] + +---------------------------------------------------------------------- +-- | CFG to Prolog +prtCGrammar :: CGrammar -> String +prtCGrammar rules = prtCHeader +++++ unlines (map (prtCRule "") rules) + +prtCHeader :: String +prtCHeader = prtLine ++++ + "%% Context-free grammar in Prolog-readable format" ++++ + "%% Autogenerated from the Grammatical Framework" +++++ + "%% The following predicate is defined:" ++++ + "%% \t rule(Profile, Cat, [Symbol,...])" + +prtCRule :: String -> CRule -> String +prtCRule lang (CFRule cat syms name) + = (if null lang then "" else prtQ lang ++ " : ") ++ + prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "." + where plname = prtName name + plcat = prtQ cat + plsyms = prtPList (map prtCSymbol syms) + +prtCSymbol (Cat cat) = prtFunctor "cat" [prtQ cat] +prtCSymbol (Tok tok) = prtFunctor "tok" [prtQ tok] + +---------------------------------------------------------------------- +-- profiles, quoted strings and more + +prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")" +prtPList xs = "[" ++ prtSep ", " xs ++ "]" +prtOper f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")" + +prtName name@(Name fun profiles) + | name == coercionName = "1" + | and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun + | otherwise = prtFunctor (prtQ fun) (map prtProfile profiles) + +prtProfile (Unify []) = " ? " +prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . succ) args) +prtProfile (Constant forest) = prtForest forest + +prtForest (FMeta) = " ? " +prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (map prtForest fs) +prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (map prtForest fs) | + fs <- fss ] + +prtQ atom = prtQStr (prt atom) + +prtQStr atom@(x:xs) + | isLower x && all isAlphaNumUnder xs = atom + where isAlphaNumUnder '_' = True + isAlphaNumUnder x = isAlphaNum x +prtQStr atom = "'" ++ concatMap esc (prt atom) ++ "'" + where esc '\'' = "\\'" + esc '\n' = "\\n" + esc '\t' = "\\t" + esc c = [c] + +prtVar var = reprime (prt var) + where reprime "" = "" + reprime ('\'' : cs) = "_0" ++ reprime cs + reprime (c:cs) = c : reprime cs + +prtLine = replicate 70 '%' + + diff --git a/src-3.0/GF/Conversion/RemoveEpsilon.hs b/src-3.0/GF/Conversion/RemoveEpsilon.hs new file mode 100644 index 000000000..0e5dafb38 --- /dev/null +++ b/src-3.0/GF/Conversion/RemoveEpsilon.hs @@ -0,0 +1,46 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 08:11:32 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.3 $ +-- +-- Removing epsilon linearizations from MCF grammars +----------------------------------------------------------------------------- + + +module GF.Conversion.RemoveEpsilon where +-- (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import Control.Monad +import Data.List (mapAccumL) +import Data.Maybe (mapMaybe) +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Conversion.Types +import GF.Data.Assoc +import GF.Data.SortedList +import GF.Data.GeneralDeduction + +convertGrammar :: EGrammar -> EGrammar +convertGrammar grammar = trace2 "RemoveEpsilon: initialEmpties" (prt initialEmpties) $ + trace2 "RemoveEpsilon: emptyCats" (prt emptyCats) $ + grammar + where initialEmpties = nubsort [ (cat, lbl) | + Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar, + Lin lbl [] <- lins ] + emptyCats = limitEmpties initialEmpties + limitEmpties es = if es==es' then es else limitEmpties es' + where es' = nubsort [ (cat, lbl) | Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar, + Lin lbl rhs <- lins, + all (symbol (\(c,l,n) -> (c,l) `elem` es) (const False)) rhs ] + + + diff --git a/src-3.0/GF/Conversion/RemoveErasing.hs b/src-3.0/GF/Conversion/RemoveErasing.hs new file mode 100644 index 000000000..1dc2560fc --- /dev/null +++ b/src-3.0/GF/Conversion/RemoveErasing.hs @@ -0,0 +1,113 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:44 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.3 $ +-- +-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1) +----------------------------------------------------------------------------- + + +module GF.Conversion.RemoveErasing + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import Control.Monad +import Data.List (mapAccumL) +import Data.Maybe (mapMaybe) +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Conversion.Types +import GF.Data.Assoc +import GF.Data.SortedList +import GF.Data.GeneralDeduction + +convertGrammar :: EGrammar -> [SCat] -> MGrammar +convertGrammar grammar starts = newGrammar + where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $ + [ rule | NR rule <- chartLookup finalChart True ] + finalChart = tracePrt "RemoveErasing - nonerasing cats" + (prt . length . flip chartLookup False) $ + buildChart keyof [newRules rulesByCat] $ + tracePrt "RemoveErasing - initial ne-cats" (prt . length) $ + initialCats + initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $ + if null starts + then trace2 "RemoveErasing" "initialCatsBU" $ + initialCatsBU rulesByCat + else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $ + initialCatsTD rulesByCat starts + rulesByCat = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $ + accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ] + +data Item r c = NR r | NC c deriving (Eq, Ord, Show) + +keyof (NR _) = True +keyof (NC _) = False + +newRules grammar chart (NR (Rule (Abs _ cats _) _)) + = [ NC cat | cat@(MCat _ lbls) <- cats, not (null lbls) ] +newRules grammar chart (NC newCat@(MCat cat lbls)) + = do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat + + lins <- selectLins lins0 lbls + -- let lins = [ lin | lin@(Lin lbl _) <- lins0, + -- lbl `elem` lbls ] + + let argsInLin = listAssoc $ + map (\((n,c),l) -> (n, MCat c l)) $ + groupPairs $ nubsort $ + [ ((nr, cat), lbl) | + Lin _ lin <- lins, + Cat (cat, lbl, nr) <- lin ] + + newArgs = mapMaybe (lookupAssoc argsInLin) [0 .. length args-1] + argLbls = [ lbls | MCat _ lbls <- newArgs ] + + newLins = [ Lin lbl newLin | Lin lbl lin <- lins, + let newLin = map (mapSymbol cnvCat id) lin ] + cnvCat (cat, lbl, nr) = (mcat, lbl, nr') + where Just mcat = lookupAssoc argsInLin nr + Unify [nr'] = newProfile !! nr + nonEmptyCat (Cat (MCat _ [], _, _)) = False + nonEmptyCat _ = True + + newProfile = snd $ mapAccumL accumProf 0 $ + map (lookupAssoc argsInLin) [0 .. length args-1] + accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr]) + newName = -- tracePrt "newName" (prtNewName profile newProfile) $ + Name fun (profile `composeProfiles` newProfile) + + guard $ all (not . null) argLbls + return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins)) + +selectLins lins0 = mapM selectLbl + where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ] + + +prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String +prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n + + +initialCatsTD grammar starts = + [ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar, + start `elem` starts ] + +initialCatsBU grammar + = [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar, + let Rule _ (Cnc lbls _ _) = head rules, + lbl <- lbls ] + + + + + + + diff --git a/src-3.0/GF/Conversion/RemoveSingletons.hs b/src-3.0/GF/Conversion/RemoveSingletons.hs new file mode 100644 index 000000000..4b9992a4d --- /dev/null +++ b/src-3.0/GF/Conversion/RemoveSingletons.hs @@ -0,0 +1,82 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/11 10:28:16 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- Instantiating all types which only have one single element. +-- +-- Should be merged into 'GF.Conversion.FiniteToSimple' +----------------------------------------------------------------------------- + +module GF.Conversion.RemoveSingletons where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Conversion.Types + +import GF.Data.SortedList +import GF.Data.Assoc + +import Data.List (mapAccumL) + +convertGrammar :: SGrammar -> SGrammar +convertGrammar grammar = if singles == emptyAssoc then grammar + else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $ + map (convertRule singles) grammar + where singles = calcSingletons grammar + +convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule +convertRule singles rule@(Rule (Abs _ decls _) _) + = if all (Nothing ==) singleArgs then rule + else instantiateSingles singleArgs rule + where singleArgs = map (lookupAssoc singles . decl2cat) decls + +instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule +instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm)) + = Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm') + where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ] + profile' = map (fmap fst) exProfile `composeProfiles` profile + newArgs = map (fmap snd) exProfile + lterm' = fmap (instantiateLin newArgs) lterm + exProfile = snd $ mapAccumL mkProfile 0 singleArgs + mkProfile nr (Just trm) = (nr, Constant trm) + mkProfile nr (Nothing) = (nr+1, Unify [nr]) + +instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm +instantiateLin newArgs = inst + where inst (Arg nr cat path) + = case newArgs !! nr of + Unify [nr'] -> Arg nr' cat path + Constant (Just term) -> termFollowPath path term + Constant Nothing -> error "RemoveSingletons.instantiateLin: This should not happen (argument has no linearization)" + inst (cn :^ terms) = cn :^ map inst terms + inst (Rec rec) = Rec [ (lbl, inst term) | (lbl, term) <- rec ] + inst (term :. lbl) = inst term +. lbl + inst (Tbl tbl) = Tbl [ (pat, inst term) | (pat, term) <- tbl ] + inst (term :! sel) = inst term +! inst sel + inst (Variants ts) = variants (map inst ts) + inst (t1 :++ t2) = inst t1 ?++ inst t2 + inst term = term + +---------------------------------------------------------------------- + +calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm) +calcSingletons rules = listAssoc singleCats + where singleCats = tracePrt "RemoveSingletons - singleton cats" (prtSep " ") $ + [ (cat, (constantNameToForest name, lin)) | + (cat, [([], name, lin)]) <- rulesByCat ] + rulesByCat = groupPairs $ nubsort + [ (decl2cat cat, (args, name, lin)) | + Rule (Abs cat args name) (Cnc _ _ lin) <- rules ] + + + diff --git a/src-3.0/GF/Conversion/SimpleToFCFG.hs b/src-3.0/GF/Conversion/SimpleToFCFG.hs new file mode 100644 index 000000000..4ff5781f9 --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToFCFG.hs @@ -0,0 +1,536 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Conversion/SimpleToFinite.hs b/src-3.0/GF/Conversion/SimpleToFinite.hs new file mode 100644 index 000000000..bbd3ae355 --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToFinite.hs @@ -0,0 +1,178 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/01 09:53:19 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.7 $ +-- +-- Calculating the finiteness of each type in a grammar +----------------------------------------------------------------------------- + +module GF.Conversion.SimpleToFinite + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Formalism.Utilities +import GF.Conversion.Types + +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Data.BacktrackM +import GF.Data.Utilities (lookupList) + +import GF.Infra.Ident (Ident(..)) + +type CnvMonad a = BacktrackM () a + +convertGrammar :: SGrammar -> SGrammar +convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $ + solutions cnvMonad () + where split = calcSplitable rules + cnvMonad = member rules >>= convertRule split + +convertRule :: Splitable -> SRule -> CnvMonad SRule +convertRule split (Rule abs cnc) + = do newAbs <- convertAbstract split abs + return $ Rule newAbs cnc + +{- +-- old code +convertAbstract :: Splitable -> Abstract SDecl Name + -> CnvMonad (Abstract SDecl Name) +convertAbstract split (Abs decl decls name) + = case splitableFun split (name2fun name) of + Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name + Nothing -> expandTyping split name [] decl decls [] + + +expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl] + -> CnvMonad (Abstract SDecl Name) +expandTyping split name env (Decl x cat args) [] decls + = return $ Abs decl (reverse decls) name + where decl = substArgs split x env cat args [] +expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone + = do (x', xcat', env') <- calcNewEnv + let decl = substArgs split x' env xcat' xargs [] + expandTyping split name env' typ declsToDo (decl : declsDone) + where calcNewEnv = case splitableCat split xcat of + Just newFuns -> do newFun <- member newFuns + let newCat = mergeFun newFun xcat + -- Just newCats -> do newCat <- member newCats + return (anyVar, newCat, (x,newCat) : env) + Nothing -> return (x, xcat, env) +-} + +-- new code +convertAbstract :: Splitable -> Abstract SDecl Name + -> CnvMonad (Abstract SDecl Name) +convertAbstract split (Abs decl decls name) + = case splitableFun split fun of + Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name + Nothing -> expandTyping split [] fun profiles [] decl decls [] + where Name fun profiles = name + +expandTyping :: Splitable -> [(Var, SCat)] + -> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] + -> SDecl -> [SDecl] -> [SDecl] + -> CnvMonad (Abstract SDecl Name) +expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls + = return $ Abs decl (reverse decls) (Name fun (reverse profiles)) + where decl = substArgs split x env typargs cat args [] +expandTyping split env fun (prof:profiles) profsDone typ + (Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone + = do (x', xcat', env', prof') <- calcNewEnv + let decl = substArgs split x' env xtypargs xcat' xargs [] + expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone) + where calcNewEnv = case splitableCat split xcat of + Nothing -> return (x, xcat, env, prof) + Just newFuns -> do newFun <- member newFuns + let newCat = mergeFun newFun xcat + newProf = Constant (FNode newFun [[]]) + -- should really be using some kind of + -- "profile unification" + return (anyVar, newCat, (x,newCat) : env, newProf) + +substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat] + -> SCat -> [TTerm] -> [TTerm] -> SDecl +substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args)) +substArgs split x env typargs cat (arg:argsToDo) argsDone + = case argLookup split env arg of + Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone + Nothing -> substArgs split x env typargs cat argsToDo (arg : argsDone) + +argLookup split env (TVar x) = lookup x env +argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun) + where fun = constr2fun con + + +---------------------------------------------------------------------- +-- splitable categories (finite, no dependencies) +-- they should also be used as some dependency + +type Splitable = (Assoc SCat [Fun], Assoc Fun SCat) + +splitableCat :: Splitable -> SCat -> Maybe [Fun] +splitableCat = lookupAssoc . fst + +splitableFun :: Splitable -> Fun -> Maybe SCat +splitableFun = lookupAssoc . snd + +calcSplitable :: [SRule] -> Splitable +calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) + where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns + + splitableFun2Cat = nubsort + [ (fun, cat) | (cat, fun) <- splitableCatFuns ] + + -- cat-fun pairs that are splitable + splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $ + [ (cat, name2fun name) | + Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules, + splitableCats ?= cat ] + + -- all cats that are splitable + splitableCats = listSet $ + tracePrt "SimpleToFinite - finite categories to split" prt $ + (nondepCats <**> depCats) <\\> resultCats + + -- all result cats for some pure function + resultCats = tracePrt "SimpleToFinite - result cats" prt $ + nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules, + not (null decls) ] + + -- all cats in constants without dependencies + nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $ + nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ] + + -- all cats occurring as some dependency of another cat + depCats = tracePrt "SimpleToFinite - dep cats" prt $ + nubsort [ cat | Rule (Abs decl decls _) _ <- rules, + cat <- varCats [] (decls ++ [decl]) ] + + varCats _ [] = [] + varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls) + = varCats ((x,xcat) : env) decls ++ + [ cat | (_::@args) <- (xtyp:xargs), arg <- args, + y <- varsInTTerm arg, cat <- lookupList y env ] + + +---------------------------------------------------------------------- +-- utilities +-- mergeing categories + +mergeCats :: String -> String -> String -> SCat -> SCat -> SCat +mergeCats before middle after (IC cat) (IC arg) + = IC (before ++ cat ++ middle ++ arg ++ after) + +mergeFun, mergeArg :: SCat -> SCat -> SCat +mergeFun = mergeCats "{" ":" "}" +mergeArg = mergeCats "" "" "" + + diff --git a/src-3.0/GF/Conversion/SimpleToMCFG.hs b/src-3.0/GF/Conversion/SimpleToMCFG.hs new file mode 100644 index 000000000..8f23c905d --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToMCFG.hs @@ -0,0 +1,26 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/18 14:55:32 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.3 $ +-- +-- All different conversions from SimpleGFC to MCFG +----------------------------------------------------------------------------- + +module GF.Conversion.SimpleToMCFG where + +import GF.Formalism.SimpleGFC +import GF.Conversion.Types + +import qualified GF.Conversion.SimpleToMCFG.Strict as Strict +import qualified GF.Conversion.SimpleToMCFG.Nondet as Nondet +import qualified GF.Conversion.SimpleToMCFG.Coercions as Coerce + +convertGrammarNondet, convertGrammarStrict :: SGrammar -> EGrammar +convertGrammarNondet = Coerce.addCoercions . Nondet.convertGrammar +convertGrammarStrict = Strict.convertGrammar + diff --git a/src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs b/src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs new file mode 100644 index 000000000..319b99dcb --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs @@ -0,0 +1,63 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:44 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- Adding coercion functions to a MCFG if necessary. +----------------------------------------------------------------------------- + + +module GF.Conversion.SimpleToMCFG.Coercions + (addCoercions) where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Conversion.Types +import GF.Data.SortedList +import Data.List (groupBy) + +---------------------------------------------------------------------- + +addCoercions :: EGrammar -> EGrammar +addCoercions rules = coercions ++ rules + where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | + Rule (Abs head args _) (Cnc lbls _ _) <- rules ] + allHeadSet = nubsort allHeads + allArgSet = union allArgs <\\> map fst allHeadSet + coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $ + concat $ + tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category" + (prtList . map length) $ + combineCoercions + (groupBy sameECatFst allHeadSet) + (groupBy sameECat allArgSet) + sameECatFst a b = sameECat (fst a) (fst b) + + +combineCoercions [] _ = [] +combineCoercions _ [] = [] +combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) + = case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of + LT -> combineCoercions allHeads allArgs' + GT -> combineCoercions allHeads' allArgs + EQ -> makeCoercion heads args : combineCoercions allHeads allArgs + + +makeCoercion heads args + = [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins) | + (head@(ECat _ headCns), lbls) <- heads, + let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], + arg@(ECat _ argCns) <- args, + argCns `subset` headCns ] + + + diff --git a/src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs b/src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs new file mode 100644 index 000000000..d6ff052f5 --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToMCFG/Nondet.hs @@ -0,0 +1,256 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/17 08:27:29 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.7 $ +-- +-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. +-- Afterwards, the grammar has to be extended with coercion functions, +-- from the module 'GF.Conversion.SimpleToMCFG.Coercions' +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +----------------------------------------------------------------------------- + + +module GF.Conversion.SimpleToMCFG.Nondet + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import Control.Monad + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.SimpleGFC +import GF.Conversion.Types + +import GF.Data.BacktrackM +import GF.Data.Utilities (notLongerThan, updateNthM) + +------------------------------------------------------------ +-- type declarations + +type CnvMonad a = BacktrackM Env a + +type Env = (ECat, [ECat], LinRec, [SLinType]) -- variable bindings: [(Var, STerm)] +type LinRec = [Lin SCat MLabel Token] + + +---------------------------------------------------------------------- +-- main conversion function + +maxNrRules :: Int +maxNrRules = 5000 + +convertGrammar :: SGrammar -> EGrammar +convertGrammar rules = traceCalcFirst rules' $ + tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $ + rules' + where rules' = rules >>= convertRule +-- solutions conversion undefined +-- where conversion = member rules >>= convertRule + +convertRule :: SRule -> [ERule] -- CnvMonad ERule +convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) = +-- | prt(name2fun fun) `elem` +-- words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" = + if notLongerThan maxNrRules rules + then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $ + rules + else trace2 "SimpeToMCFG.Nondet - TOO MANY RULES, function not converted" + ("More than " ++ show maxNrRules ++ " MCFG rules for " ++ prt fun) $ + [] + where rules = flip solutions undefined $ + do let cat : args = map decl2cat (decl : decls) + writeState (initialECat cat, map initialECat args, [], ctypes) + rterm <- simplifyTerm term + reduceTerm ctype emptyPath rterm + (newCat, newArgs, linRec, _) <- readState + let newLinRec = map (instantiateArgs newArgs) linRec + catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes) + -- checkLinRec argsPaths catPaths newLinRec + return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) +convertRule _ = [] -- failure + + +---------------------------------------------------------------------- +-- "type-checking" the resulting linearization +-- should not be necessary, if the algorithms (type-checking and conversion) are correct + +checkLinRec args lbls = mapM (checkLin args lbls) + +checkLin args lbls (Lin lbl lin) + | lbl `elem` lbls = mapM (symbol (checkArg args) (const (return ()))) lin + | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" "Label mismatch" $ + failure + +checkArg args (_cat, lbl, nr) + | lbl `elem` (args !! nr) = return () +-- | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" ("Label mismatch in arg " ++ prt nr) $ +-- failure + | otherwise = trace2 ("SimpleToMCFG.Nondet - ERROR: Label mismatch in arg " ++ prt nr) + (prt lbl ++ " `notElem` " ++ prt (args!!nr)) $ + failure + + +---------------------------------------------------------------------- +-- term simplification + +simplifyTerm :: STerm -> CnvMonad STerm +simplifyTerm (term :! sel) + = do sterm <- simplifyTerm term + ssel <- simplifyTerm sel + case sterm of + Tbl table -> do (pat, val) <- member table + pat =?= ssel + return val + _ -> do sel' <- expandTerm ssel + return (sterm +! sel') +-- simplifyTerm (Var x) = readBinding x +simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms +simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record +simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term +simplifyTerm (Tbl table) = liftM Tbl $ mapM simplifyCase table +simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms +simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2) +simplifyTerm term = return term + +simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm) +simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term + +simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm) +simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) + + +------------------------------------------------------------ +-- reducing simplified terms, collecting MCF rules + +reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad () +--reduceTerm ctype path (Variants terms) +-- = member terms >>= reduceTerm ctype path +reduceTerm (StrT) path term = updateLin (path, term) +reduceTerm (ConT _) path term = do pat <- expandTerm term + updateHead (path, pat) +reduceTerm (RecT rtype) path term + = sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | (lbl, ctype) <- rtype ] +reduceTerm (TblT pats vtype) path table + = sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ] + + +------------------------------------------------------------ +-- expanding a term to ground terms + +expandTerm :: STerm -> CnvMonad STerm +expandTerm arg@(Arg nr _ path) + = do ctypes <- readArgCTypes + unifyPType arg $ lintypeFollowPath path $ ctypes !! nr +-- expandTerm arg@(Arg nr _ path) +-- = do ctypes <- readArgCTypes +-- pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr +-- pat =?= arg +-- return pat +expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms +expandTerm (Rec record) = liftM Rec $ mapM expandAssign record +--expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms +expandTerm (Variants terms) = member terms >>= expandTerm +expandTerm term = error $ "expandTerm: " ++ prt term + +expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) +expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term + +unifyPType :: STerm -> SLinType -> CnvMonad STerm +unifyPType arg (RecT prec) = + liftM Rec $ + sequence [ liftM ((,) lbl) $ + unifyPType (arg +. lbl) ptype | + (lbl, ptype) <- prec ] +unifyPType (Arg nr _ path) (ConT terms) = + do (_, args, _, _) <- readState + case lookup path (ecatConstraints (args !! nr)) of + Just term -> return term + Nothing -> do term <- member terms + updateArg nr (path, term) + return term + +------------------------------------------------------------ +-- unification of patterns and selection terms + +(=?=) :: STerm -> STerm -> CnvMonad () +-- Wildcard =?= _ = return () +-- Var x =?= term = addBinding x term +Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | + (lbl, pat) <- precord ] +pat =?= Arg nr _ path = updateArg nr (path, pat) +(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms) + sequence_ $ zipWith (=?=) pats terms +Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm | + (lbl, pat) <- precord, + let mterm = lookup lbl record ] +-- variants are not allowed in patterns, but in selection terms: +term =?= Variants terms = member terms >>= (term =?=) +pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term + +---------------------------------------------------------------------- +-- variable bindings (does not work correctly) +{- +addBinding x term = do (a, b, c, d, bindings) <- readState + writeState (a, b, c, d, (x,term):bindings) + +readBinding x = do (_, _, _, _, bindings) <- readState + return $ maybe (Var x) id $ lookup x bindings +-} + +------------------------------------------------------------ +-- updating the MCF rule + +readArgCTypes :: CnvMonad [SLinType] +readArgCTypes = do (_, _, _, env) <- readState + return env + +updateArg :: Int -> Constraint -> CnvMonad () +updateArg arg cn + = do (head, args, lins, env) <- readState + args' <- updateNthM (addToECat cn) arg args + writeState (head, args', lins, env) + +updateHead :: Constraint -> CnvMonad () +updateHead cn + = do (head, args, lins, env) <- readState + head' <- addToECat cn head + writeState (head', args, lins, env) + +updateLin :: Constraint -> CnvMonad () +updateLin (path, term) + = do let newLins = term2lins term + (head, args, lins, env) <- readState + let lins' = lins ++ map (Lin path) newLins + writeState (head, args, lins', env) + +term2lins :: STerm -> [[Symbol (SCat, SPath, Int) Token]] +term2lins (Arg nr cat path) = return [Cat (cat, path, nr)] +term2lins (Token str) = return [Tok str] +term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2) +term2lins (Empty) = return [] +term2lins (Variants terms) = terms >>= term2lins +term2lins term = error $ "term2lins: " ++ show term + +addToECat :: Constraint -> ECat -> CnvMonad ECat +addToECat cn (ECat cat cns) = liftM (ECat cat) $ addConstraint cn cns + +addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] +addConstraint cn0 (cn : cns) + | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) + | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> + return (cn : cns) +addConstraint cn0 cns = return (cn0 : cns) + + + diff --git a/src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs b/src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs new file mode 100644 index 000000000..a5519fcd8 --- /dev/null +++ b/src-3.0/GF/Conversion/SimpleToMCFG/Strict.hs @@ -0,0 +1,129 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:44 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- Converting SimpleGFC grammars to MCFG grammars, deterministic. +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +----------------------------------------------------------------------------- + + +module GF.Conversion.SimpleToMCFG.Strict + (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import Control.Monad + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.SimpleGFC +import GF.Conversion.Types + +import GF.Data.BacktrackM +import GF.Data.SortedList + +---------------------------------------------------------------------- +-- main conversion function + +type CnvMonad a = BacktrackM () a + +convertGrammar :: SGrammar -> EGrammar +convertGrammar rules = tracePrt "SimpleToMCFG.Strict - MCFG rules" (prt . length) $ + solutions conversion undefined + where conversion = member rules >>= convertRule + +convertRule :: SRule -> CnvMonad ERule +convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) + = do let cat : args = map decl2cat (decl : decls) + args_ctypes = zip3 [0..] args ctypes + instArgs <- mapM enumerateArg args_ctypes + let instTerm = substitutePaths instArgs term + newCat <- extractECat cat ctype instTerm + newArgs <- mapM (extractArg instArgs) args_ctypes + let linRec = strPaths ctype instTerm >>= extractLin newArgs + let newLinRec = map (instantiateArgs newArgs) linRec + catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes) + return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) +convertRule _ = failure + +---------------------------------------------------------------------- +-- category extraction + +extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad ECat +extractArg args (nr, cat, ctype) = extractECat cat ctype (args !! nr) + +extractECat :: SCat -> SLinType -> STerm -> CnvMonad ECat +extractECat cat ctype term = member $ map (ECat cat) $ parPaths ctype term + +enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm +enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype + +---------------------------------------------------------------------- +-- Substitute each instantiated parameter path for its instantiation + +substitutePaths :: [STerm] -> STerm -> STerm +substitutePaths arguments = subst + where subst (Arg nr _ path) = termFollowPath path (arguments !! nr) + subst (con :^ terms) = con :^ map subst terms + subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ] + subst (term :. lbl) = subst term +. lbl + subst (Tbl table) = Tbl [ (pat, subst term) | + (pat, term) <- table ] + subst (term :! select) = subst term +! subst select + subst (term :++ term') = subst term ?++ subst term' + subst (Variants terms) = Variants $ map subst terms + subst term = term + +---------------------------------------------------------------------- +-- term paths extaction + +termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))] +termPaths ctype (Variants terms) = terms >>= termPaths ctype +termPaths (RecT rtype) (Rec record) + = [ (path ++. lbl, value) | + (lbl, term) <- record, + let Just ctype = lookup lbl rtype, + (path, value) <- termPaths ctype term ] +termPaths (TblT _ ctype) (Tbl table) + = [ (path ++! pat, value) | + (pat, term) <- table, + (path, value) <- termPaths ctype term ] +termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ] + +{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): +{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} +[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] +-} + +parPaths :: SLinType -> STerm -> [[(SPath, STerm)]] +parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ + nubsort [ (path, value) | + (path, (ConT _, value)) <- termPaths ctype term ] + +strPaths :: SLinType -> STerm -> [(SPath, STerm)] +strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ] + where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ] + +---------------------------------------------------------------------- +-- linearization extraction + +extractLin :: [ECat] -> (SPath, STerm) -> [Lin ECat MLabel Token] +extractLin args (path, term) = map (Lin path) (convertLin term) + where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2) + convertLin (Empty) = [[]] + convertLin (Token tok) = [[Tok tok]] + convertLin (Variants terms) = concatMap convertLin terms + convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]] + convertLin t = error $ "convertLin: " ++ prt t ++ " " ++ prt (args, path) + diff --git a/src-3.0/GF/Conversion/TypeGraph.hs b/src-3.0/GF/Conversion/TypeGraph.hs new file mode 100644 index 000000000..62ee9726e --- /dev/null +++ b/src-3.0/GF/Conversion/TypeGraph.hs @@ -0,0 +1,58 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/16 10:21:21 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.2 $ +-- +-- Printing the type hierarchy of an abstract module in GraphViz format +----------------------------------------------------------------------------- + + +module GF.Conversion.TypeGraph (prtTypeGraph, prtFunctionGraph) where + +import GF.Formalism.GCFG +import GF.Formalism.SimpleGFC +import GF.Formalism.Utilities +import GF.Conversion.Types + +import GF.Data.Operations ((++++), (+++++)) +import GF.Infra.Print + +---------------------------------------------------------------------- +-- | SimpleGFC to TypeGraph +-- +-- assumes that the profiles in the Simple GFC names are trivial + +prtTypeGraph :: SGrammar -> String +prtTypeGraph rules = "digraph TypeGraph {" ++++ + "concentrate=true;" ++++ + "node [shape=ellipse];" +++++ + unlines (map prtTypeGraphRule rules) +++++ + "}" + +prtTypeGraphRule :: SRule -> String +prtTypeGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _) + = "// " ++ prt abs ++++ + unlines [ prtSCat c ++ " -> " ++ prtSCat cat ++ ";" | c <- cats ] + +prtFunctionGraph :: SGrammar -> String +prtFunctionGraph rules = "digraph FunctionGraph {" ++++ + "node [shape=ellipse];" +++++ + unlines (map prtFunctionGraphRule rules) +++++ + "}" + +prtFunctionGraphRule :: SRule -> String +prtFunctionGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _) + = "// " ++ prt abs ++++ + pfun ++ " [label=\"" ++ prt fun ++ "\", shape=box, style=dashed];" ++++ + pfun ++ " -> " ++ prtSCat cat ++ ";" ++++ + unlines [ prtSCat c ++ " -> " ++ pfun ++ ";" | c <- cats ] + where pfun = "GF_FUNCTION_" ++ prt fun + +prtSCat decl = prt (decl2cat decl) + + diff --git a/src-3.0/GF/Conversion/Types.hs b/src-3.0/GF/Conversion/Types.hs new file mode 100644 index 000000000..97c2ace05 --- /dev/null +++ b/src-3.0/GF/Conversion/Types.hs @@ -0,0 +1,146 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/Assoc.hs b/src-3.0/GF/Data/Assoc.hs new file mode 100644 index 000000000..f775319ea --- /dev/null +++ b/src-3.0/GF/Data/Assoc.hs @@ -0,0 +1,143 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/BacktrackM.hs b/src-3.0/GF/Data/BacktrackM.hs new file mode 100644 index 000000000..790d11a83 --- /dev/null +++ b/src-3.0/GF/Data/BacktrackM.hs @@ -0,0 +1,93 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/Compos.hs b/src-3.0/GF/Data/Compos.hs new file mode 100644 index 000000000..7d46fc5a2 --- /dev/null +++ b/src-3.0/GF/Data/Compos.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module GF.Data.Compos (Compos(..),composOp,composM,composM_,composFold) where + +import Control.Applicative (Applicative(..), Const(..), WrappedMonad(..)) +import Data.Monoid (Monoid(..)) + +class Compos t where + compos :: Applicative f => (forall a. t a -> f (t a)) -> t c -> f (t c) + +composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c +composOp f = runIdentity . compos (Identity . f) + +composFold :: (Monoid o, Compos t) => (forall a. t a -> o) -> t c -> o +composFold f = getConst . compos (Const . f) + +composM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c) +composM f = unwrapMonad . compos (WrapMonad . f) + +composM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m () +composM_ f = unwrapMonad_ . composFold (WrapMonad_ . f) + + +newtype Identity a = Identity { runIdentity :: a } + +instance Functor Identity where + fmap f (Identity x) = Identity (f x) + +instance Applicative Identity where + pure = Identity + Identity f <*> Identity x = Identity (f x) + + +newtype WrappedMonad_ m = WrapMonad_ { unwrapMonad_ :: m () } + +instance Monad m => Monoid (WrappedMonad_ m) where + mempty = WrapMonad_ (return ()) + WrapMonad_ x `mappend` WrapMonad_ y = WrapMonad_ (x >> y) diff --git a/src-3.0/GF/Data/ErrM.hs b/src-3.0/GF/Data/ErrM.hs new file mode 100644 index 000000000..e8cea12d4 --- /dev/null +++ b/src-3.0/GF/Data/ErrM.hs @@ -0,0 +1,38 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/GeneralDeduction.hs b/src-3.0/GF/Data/GeneralDeduction.hs new file mode 100644 index 000000000..137212e5c --- /dev/null +++ b/src-3.0/GF/Data/GeneralDeduction.hs @@ -0,0 +1,121 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/Glue.hs b/src-3.0/GF/Data/Glue.hs new file mode 100644 index 000000000..4f276222b --- /dev/null +++ b/src-3.0/GF/Data/Glue.hs @@ -0,0 +1,30 @@ +---------------------------------------------------------------------- +-- | +-- Module : Glue +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:02 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.7 $ +-- +-- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@ +----------------------------------------------------------------------------- + +module GF.Data.Glue (decomposeSimple) where + +import GF.Data.Trie2 +import GF.Data.Operations +import Data.List + +decomposeSimple :: Trie Char a -> [Char] -> Err [[Char]] +decomposeSimple t s = do + let ss = map (decompose t) $ words s + if any null ss + then Bad "unknown word in input" + else return $ concat [intersperse "&+" ws | ws <- ss] + +exTrie = tcompile (zip ws ws) where + ws = words "ett tv\229 tre tjugo trettio hundra tusen" + diff --git a/src-3.0/GF/Data/IncrementalDeduction.hs b/src-3.0/GF/Data/IncrementalDeduction.hs new file mode 100644 index 000000000..d119610c1 --- /dev/null +++ b/src-3.0/GF/Data/IncrementalDeduction.hs @@ -0,0 +1,67 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:44 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.3 $ +-- +-- Implementation of /incremental/ deductive parsing, +-- i.e. parsing one word at the time. +----------------------------------------------------------------------------- + +module GF.Data.IncrementalDeduction + (-- * Type definitions + IncrementalChart, + -- * Functions + chartLookup, + buildChart, + chartList, chartKeys + ) where + +import Data.Array +import GF.Data.SortedList +import GF.Data.Assoc + +---------------------------------------------------------------------- +-- main functions + +chartLookup :: (Ord item, Ord key) => + IncrementalChart item key + -> Int -> key -> SList item + +buildChart :: (Ord item, Ord key) => + (item -> key) -- ^ key lookup function + -> (Int -> item -> SList item) -- ^ all inference rules for position k, collected + -> (Int -> SList item) -- ^ all axioms for position k, collected + -> (Int, Int) -- ^ input bounds + -> IncrementalChart item key + +chartList :: (Ord item, Ord key) => + IncrementalChart item key -- ^ the final chart + -> (Int -> item -> edge) -- ^ function building an edge from + -- the position and the item + -> [edge] + +chartKeys :: (Ord item, Ord key) => IncrementalChart item key -> Int -> [key] + +type IncrementalChart item key = Array Int (Assoc key (SList item)) + +---------- + +chartLookup chart k key = (chart ! k) ? key + +buildChart keyof rules axioms bounds = finalChartArray + where buildState k = limit (rules k) $ axioms k + finalChartList = map buildState [fst bounds .. snd bounds] + finalChartArray = listArray bounds $ map stateAssoc finalChartList + stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ] + +chartList chart combine = [ combine k item | + (k, state) <- assocs chart, + item <- concatMap snd $ aAssocs state ] + +chartKeys chart k = aElems (chart ! k) + diff --git a/src-3.0/GF/Data/Map.hs b/src-3.0/GF/Data/Map.hs new file mode 100644 index 000000000..c86c9ab55 --- /dev/null +++ b/src-3.0/GF/Data/Map.hs @@ -0,0 +1,61 @@ +---------------------------------------------------------------------- +-- | +-- Module : Map +-- Maintainer : Markus Forsberg +-- Stability : Stable +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:04 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Data.Map ( + Map, + empty, + isEmpty, + (!), + (!+), + (|->), + (|->+), + (<+>), + flatten + ) where + +import GF.Data.RedBlack + +type Map key el = Tree key el + +infixl 6 |-> +infixl 6 |->+ +infixl 5 ! +infixl 5 !+ +infixl 4 <+> + +empty :: Map key el +empty = emptyTree + +-- | lookup operator. +(!) :: Ord key => Map key el -> key -> Maybe el +(!) fm e = lookupTree e fm + +-- | lookupMany operator. +(!+) :: Ord key => Map key el -> [key] -> [Maybe el] +fm !+ [] = [] +fm !+ (e:es) = (lookupTree e fm): (fm !+ es) + +-- | insert operator. +(|->) :: Ord key => (key,el) -> Map key el -> Map key el +(x,y) |-> fm = insertTree (x,y) fm + +-- | insertMany operator. +(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el +[] |->+ fm = fm +((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm) + +-- | union operator. +(<+>) :: Ord key => Map key el -> Map key el -> Map key el +(<+>) fm1 fm2 = xs |->+ fm2 + where xs = flatten fm1 diff --git a/src-3.0/GF/Data/Operations.hs b/src-3.0/GF/Data/Operations.hs new file mode 100644 index 000000000..1b2033d69 --- /dev/null +++ b/src-3.0/GF/Data/Operations.hs @@ -0,0 +1,658 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/OrdMap2.hs b/src-3.0/GF/Data/OrdMap2.hs new file mode 100644 index 000000000..3590f0584 --- /dev/null +++ b/src-3.0/GF/Data/OrdMap2.hs @@ -0,0 +1,127 @@ +---------------------------------------------------------------------- +-- | +-- Module : OrdMap2 +-- Maintainer : Peter Ljunglöf +-- Stability : Obsolete +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:05 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- The class of finite maps, as described in +-- \"Pure Functional Parsing\", section 2.2.2 +-- and an example implementation, +-- derived from appendix A.2 +-- +-- /OBSOLETE/! this is only used in module "ChartParser" +----------------------------------------------------------------------------- + +module GF.Data.OrdMap2 (OrdMap(..), Map) where + +import Data.List (intersperse) + + +-------------------------------------------------- +-- the class of ordered finite maps + +class OrdMap m where + emptyMap :: Ord s => m s a + (|->) :: Ord s => s -> a -> m s a + isEmptyMap :: Ord s => m s a -> Bool + (?) :: Ord s => m s a -> s -> Maybe a + lookupWith :: Ord s => a -> m s a -> s -> a + mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a + unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a + makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a + assocs :: Ord s => m s a -> [(s,a)] + ordMap :: Ord s => [(s,a)] -> m s a + mapMap :: Ord s => (a -> b) -> m s a -> m s b + + lookupWith z m s = case m ? s of + Just a -> a + Nothing -> z + + unionMapWith join = union + where union [] = emptyMap + union [xs] = xs + union xyss = mergeWith join (union xss) (union yss) + where (xss, yss) = split xyss + split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) + split xs = (xs, []) + + +-------------------------------------------------- +-- finite maps as ordered associaiton lists, +-- paired with binary search trees + +data Map s a = Map [(s,a)] (TreeMap s a) + +instance (Eq s, Eq a) => Eq (Map s a) where + Map xs _ == Map ys _ = xs == ys + +instance (Show s, Show a) => Show (Map s a) where + show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}" + where show' (s,a) = show s ++ "|->" ++ show a + +instance OrdMap Map where + emptyMap = Map [] (makeTree []) + s |-> a = Map [(s,a)] (makeTree [(s,a)]) + + isEmptyMap (Map ass _) = null ass + + Map _ tree ? s = lookupTree s tree + + mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss) + where xyss = merge xss yss + merge [] yss = yss + merge xss [] = xss + merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss') + = case compare s t of + LT -> x : merge xss' yss + GT -> y : merge xss yss' + EQ -> (s, join x' y') : merge xss' yss' + + makeMapWith join [] = emptyMap + makeMapWith join [(s,a)] = s |-> a + makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss) + where (xss, yss) = split xyss + split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys) + split xs = (xs, []) + + assocs (Map xss _) = xss + ordMap xss = Map xss (makeTree xss) + + mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree) + + +-------------------------------------------------- +-- binary search trees +-- for logarithmic lookup time + +data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a) + +makeTree ass = tree + where + (tree,[]) = sl2bst (length ass) ass + sl2bst 0 ass = (Nil, ass) + sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass) + sl2bst n ass = (Node ltree s a rtree, css) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (ltree, (s,a):bss) = sl2bst llen ass + (rtree, css) = sl2bst rlen bss + +lookupTree s Nil = Nothing +lookupTree s (Node left s' a right) + = case compare s s' of + LT -> lookupTree s left + GT -> lookupTree s right + EQ -> Just a + +mapTree f Nil = Nil +mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right) + + + + diff --git a/src-3.0/GF/Data/OrdSet.hs b/src-3.0/GF/Data/OrdSet.hs new file mode 100644 index 000000000..34eb0705d --- /dev/null +++ b/src-3.0/GF/Data/OrdSet.hs @@ -0,0 +1,120 @@ +---------------------------------------------------------------------- +-- | +-- Module : OrdSet +-- Maintainer : Peter Ljunglöf +-- Stability : Obsolete +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:06 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- The class of ordered sets, as described in +-- \"Pure Functional Parsing\", section 2.2.1, +-- and an example implementation +-- derived from appendix A.1 +-- +-- /OBSOLETE/! this is only used in module "ChartParser" +----------------------------------------------------------------------------- + +module GF.Data.OrdSet (OrdSet(..), Set) where + +import Data.List (intersperse) + + +-------------------------------------------------- +-- the class of ordered sets + +class OrdSet m where + emptySet :: Ord a => m a + unitSet :: Ord a => a -> m a + isEmpty :: Ord a => m a -> Bool + elemSet :: Ord a => a -> m a -> Bool + (<++>) :: Ord a => m a -> m a -> m a + (<\\>) :: Ord a => m a -> m a -> m a + plusMinus :: Ord a => m a -> m a -> (m a, m a) + union :: Ord a => [m a] -> m a + makeSet :: Ord a => [a] -> m a + elems :: Ord a => m a -> [a] + ordSet :: Ord a => [a] -> m a + limit :: Ord a => (a -> m a) -> m a -> m a + + xs <++> ys = fst (plusMinus xs ys) + xs <\\> ys = snd (plusMinus xs ys) + plusMinus xs ys = (xs <++> ys, xs <\\> ys) + + union [] = emptySet + union [xs] = xs + union xyss = union xss <++> union yss + where (xss, yss) = split xyss + split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) + split xs = (xs, []) + + makeSet xs = union (map unitSet xs) + + limit more start = limit' (start, start) + where limit' (old, new) + | isEmpty new' = old + | otherwise = limit' (plusMinus new' old) + where new' = union (map more (elems new)) + + +-------------------------------------------------- +-- sets as ordered lists, +-- paired with a binary tree + +data Set a = Set [a] (TreeSet a) + +instance Eq a => Eq (Set a) where + Set xs _ == Set ys _ = xs == ys + +instance Ord a => Ord (Set a) where + compare (Set xs _) (Set ys _) = compare xs ys + +instance Show a => Show (Set a) where + show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}" + +instance OrdSet Set where + emptySet = Set [] (makeTree []) + unitSet a = Set [a] (makeTree [a]) + + isEmpty (Set xs _) = null xs + elemSet a (Set _ xt) = elemTree a xt + + plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms)) + where (ps, ms) = plm xs ys + plm [] ys = (ys, []) + plm xs [] = (xs, xs) + plm xs@(x:xs') ys@(y:ys') = case compare x y of + LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms) + GT -> let (ps, ms) = plm xs ys' in (y:ps, ms) + EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms) + + elems (Set xs _) = xs + ordSet xs = Set xs (makeTree xs) + + +-------------------------------------------------- +-- binary search trees +-- for logarithmic lookup time + +data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a) + +makeTree xs = tree + where (tree,[]) = sl2bst (length xs) xs + sl2bst 0 xs = (Nil, xs) + sl2bst 1 (a:xs) = (Node Nil a Nil, xs) + sl2bst n xs = (Node ltree a rtree, zs) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (ltree, a:ys) = sl2bst llen xs + (rtree, zs) = sl2bst rlen ys + +elemTree a Nil = False +elemTree a (Node ltree x rtree) + = case compare a x of + LT -> elemTree a ltree + GT -> elemTree a rtree + EQ -> True + + diff --git a/src-3.0/GF/Data/Parsers.hs b/src-3.0/GF/Data/Parsers.hs new file mode 100644 index 000000000..f9bf02598 --- /dev/null +++ b/src-3.0/GF/Data/Parsers.hs @@ -0,0 +1,196 @@ +---------------------------------------------------------------------- +-- | +-- Module : Parsers +-- Maintainer : Aarne Ranta +-- Stability : Almost Obsolete +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:06 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- some parser combinators a la Wadler and Hutton. +-- no longer used in many places in GF +-- (only used in module "EBNF") +----------------------------------------------------------------------------- + +module GF.Data.Parsers (-- * Main types and functions + Parser, parseResults, parseResultErr, + -- * Basic combinators (on any token type) + (...), (.>.), (|||), (+||), literal, (***), + succeed, fails, (+..), (..+), (<<<), (|>), + many, some, longestOfMany, longestOfSome, + closure, + -- * Specific combinators (for @Char@ token type) + pJunk, pJ, jL, pTList, pTJList, pElem, + (....), item, satisfy, literals, lits, + pParenth, pCommaList, pOptCommaList, + pArgList, pArgList2, + pIdent, pLetter, pDigit, pLetters, + pAlphanum, pAlphaPlusChar, + pQuotedString, pIntc + ) where + +import GF.Data.Operations +import Data.Char +import Data.List + + +infixr 2 |||, +|| +infixr 3 *** +infixr 5 .>. +infixr 5 ... +infixr 5 .... +infixr 5 +.. +infixr 5 ..+ +infixr 6 |> +infixr 3 <<< + + +type Parser a b = [a] -> [(b,[a])] + +parseResults :: Parser a b -> [a] -> [b] +parseResults p s = [x | (x,r) <- p s, null r] + +parseResultErr :: Show a => Parser a b -> [a] -> Err b +parseResultErr p s = case parseResults p s of + [x] -> return x + [] -> case + maximumBy (\x y -> compare (length y) (length x)) (s:[r | (_,r) <- p s]) of + r -> Bad $ "\nno parse; reached" ++++ take 300 (show r) + _ -> Bad "ambiguous" + +(...) :: Parser a b -> Parser a c -> Parser a (b,c) +(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] + +(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c +(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t] + +(|||) :: Parser a b -> Parser a b -> Parser a b +(p ||| q) s = p s ++ q s + +(+||) :: Parser a b -> Parser a b -> Parser a b +p1 +|| p2 = take 1 . (p1 ||| p2) + +literal :: (Eq a) => a -> Parser a a +literal x (c:cs) = [(x,cs) | x == c] +literal _ _ = [] + +(***) :: Parser a b -> (b -> c) -> Parser a c +(p *** f) s = [(f x,r) | (x,r) <- p s] + +succeed :: b -> Parser a b +succeed v s = [(v,s)] + +fails :: Parser a b +fails s = [] + +(+..) :: Parser a b -> Parser a c -> Parser a c +p1 +.. p2 = p1 ... p2 *** snd + +(..+) :: Parser a b -> Parser a c -> Parser a b +p1 ..+ p2 = p1 ... p2 *** fst + +(<<<) :: Parser a b -> c -> Parser a c -- return +p <<< v = p *** (\x -> v) + +(|>) :: Parser a b -> (b -> Bool) -> Parser a b +p |> b = p .>. (\x -> if b x then succeed x else fails) + +many :: Parser a b -> Parser a [b] +many p = (p ... many p *** uncurry (:)) +|| succeed [] + +some :: Parser a b -> Parser a [b] +some p = (p ... many p) *** uncurry (:) + +longestOfMany :: Parser a b -> Parser a [b] +longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed [] + +closure :: (b -> Parser a b) -> (b -> Parser a b) +closure p v = p v .>. closure p ||| succeed v + +pJunk :: Parser Char String +pJunk = longestOfMany (satisfy (\x -> elem x "\n\t ")) + +pJ :: Parser Char a -> Parser Char a +pJ p = pJunk +.. p ..+ pJunk + +pTList :: String -> Parser Char a -> Parser Char [a] +pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999 + +pTJList :: String -> String -> Parser Char a -> Parser Char [a] +pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:)) + +pElem :: [String] -> Parser Char String +pElem l = foldr (+||) fails (map literals l) + +(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c) +p1 .... p2 = p1 ... pJunk +.. p2 + +item :: Parser a a +item (c:cs) = [(c,cs)] +item [] = [] + +satisfy :: (a -> Bool) -> Parser a a +satisfy b = item |> b + +literals :: (Eq a,Show a) => [a] -> Parser a [a] +literals l = case l of + [] -> succeed [] + a:l -> literal a ... literals l *** (\ (x,y) -> x:y) + +lits :: (Eq a,Show a) => [a] -> Parser a [a] +lits ts = literals ts + +jL :: String -> Parser Char String +jL = pJ . lits + +pParenth :: Parser Char a -> Parser Char a +pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')' + +-- | p,...,p +pCommaList :: Parser Char a -> Parser Char [a] +pCommaList p = pTList "," (pJ p) + +-- | the same or nothing +pOptCommaList :: Parser Char a -> Parser Char [a] +pOptCommaList p = pCommaList p ||| succeed [] + +-- | (p,...,p), poss. empty +pArgList :: Parser Char a -> Parser Char [a] +pArgList p = pParenth (pCommaList p) ||| succeed [] + +-- | min. 2 args +pArgList2 :: Parser Char a -> Parser Char [a] +pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) + +longestOfSome :: Parser a b -> Parser a [b] +longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y) + +pIdent :: Parser Char String +pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:) + where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\'' + +pLetter, pDigit :: Parser Char Char +pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ + ['\192' .. '\255'])) -- no such in Char +pDigit = satisfy isDigit + +pLetters :: Parser Char String +pLetters = longestOfSome pLetter + +pAlphanum, pAlphaPlusChar :: Parser Char Char +pAlphanum = pDigit ||| pLetter +pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'") + +pQuotedString :: Parser Char String +pQuotedString = literal '"' +.. pEndQuoted where + pEndQuoted = + literal '"' *** (const []) + +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:)) + +|| item .>. \ c -> pEndQuoted *** (c:) + +pIntc :: Parser Char Int +pIntc = some (satisfy numb) *** read + where numb x = elem x ['0'..'9'] + diff --git a/src-3.0/GF/Data/RedBlack.hs b/src-3.0/GF/Data/RedBlack.hs new file mode 100644 index 000000000..fd70dba63 --- /dev/null +++ b/src-3.0/GF/Data/RedBlack.hs @@ -0,0 +1,64 @@ +---------------------------------------------------------------------- +-- | +-- Module : RedBlack +-- Maintainer : Markus Forsberg +-- Stability : Stable +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- Modified version of Osanaki's implementation. +----------------------------------------------------------------------------- + +module GF.Data.RedBlack ( + emptyTree, + isEmpty, + Tree, + lookupTree, + insertTree, + flatten + ) where + +data Color = R | B + deriving (Show,Read) + +data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el) + deriving (Show,Read) + +balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b +balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) +balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) +balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) +balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) +balance color a x b = T color a x b + +emptyTree :: Tree key el +emptyTree = E + +isEmpty :: Tree key el -> Bool +isEmpty (E) = True +isEmpty _ = False + +lookupTree :: Ord a => a -> Tree a b -> Maybe b +lookupTree _ E = Nothing +lookupTree x (T _ a (y,z) b) + | x < y = lookupTree x a + | x > y = lookupTree x b + | otherwise = return z + +insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b +insertTree (key,el) tree = T B a y b + where + T _ a y b = ins tree + ins E = T R E (key,el) E + ins (T color a y@(key',el') b) + | key < key' = balance color (ins a) y b + | key > key' = balance color a y (ins b) + | otherwise = T color a (key',el) b + +flatten :: Tree a b -> [(a,b)] +flatten E = [] +flatten (T _ left (key,e) right) + = (flatten left) ++ ((key,e):(flatten right)) diff --git a/src-3.0/GF/Data/RedBlackSet.hs b/src-3.0/GF/Data/RedBlackSet.hs new file mode 100644 index 000000000..8a1b8a743 --- /dev/null +++ b/src-3.0/GF/Data/RedBlackSet.hs @@ -0,0 +1,150 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/SharedString.hs b/src-3.0/GF/Data/SharedString.hs new file mode 100644 index 000000000..9d037b512 --- /dev/null +++ b/src-3.0/GF/Data/SharedString.hs @@ -0,0 +1,19 @@ + +module GF.Data.SharedString (shareString) where + +import Data.HashTable as H +import System.IO.Unsafe (unsafePerformIO) + +{-# NOINLINE stringPool #-} +stringPool :: HashTable String String +stringPool = unsafePerformIO $ new (==) hashString + +{-# NOINLINE shareString #-} +shareString :: String -> String +shareString s = unsafePerformIO $ do + mv <- H.lookup stringPool s + case mv of + Just s' -> return s' + Nothing -> do + H.insert stringPool s s + return s diff --git a/src-3.0/GF/Data/SortedList.hs b/src-3.0/GF/Data/SortedList.hs new file mode 100644 index 000000000..d77ff68d4 --- /dev/null +++ b/src-3.0/GF/Data/SortedList.hs @@ -0,0 +1,127 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/Str.hs b/src-3.0/GF/Data/Str.hs new file mode 100644 index 000000000..6f65764c7 --- /dev/null +++ b/src-3.0/GF/Data/Str.hs @@ -0,0 +1,134 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/Trie.hs b/src-3.0/GF/Data/Trie.hs new file mode 100644 index 000000000..9fb5daa27 --- /dev/null +++ b/src-3.0/GF/Data/Trie.hs @@ -0,0 +1,129 @@ +---------------------------------------------------------------------- +-- | +-- Module : Trie +-- Maintainer : Markus Forsberg +-- Stability : Obsolete +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:09 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Data.Trie ( + tcompile, + collapse, + Trie, + trieLookup, + decompose, + Attr, + atW, atP, atWP + ) where + +import GF.Data.Map + +--- data Attr = W | P | WP deriving Eq +type Attr = Int + +atW, atP, atWP :: Attr +(atW,atP,atWP) = (0,1,2) + +newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)]) + +newtype Trie = Trie (Map Char Trie, [(Attr,String)]) + +emptyTrie = TrieT ([],[]) + +optimize :: TrieT -> Trie +optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, + res) + +collapse :: Trie -> [(String,[(Attr,String)])] +collapse trie = collapse' trie [] + where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))] + else (reverse s,(x:xs)): + concat [ collapse' trie (c:s) | (c,trie) <- flatten map] + collapse' (Trie (map,[])) s + = concat [ collapse' trie (c:s) | (c,trie) <- flatten map] + +tcompile :: [(String,[(Attr,String)])] -> Trie +tcompile xs = optimize $ build xs emptyTrie + +build :: [(String,[(Attr,String)])] -> TrieT -> TrieT +build [] trie = trie +build (x:xs) trie = build xs (insert x trie) + where + insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) + insert ((s:ss),ys) (TrieT (xs,res)) + = case (span (\(s',_) -> s' /= s) xs) of + (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res) + (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) + +trieLookup :: Trie -> String -> (String,[(Attr,String)]) +trieLookup trie s = apply trie s s + +apply :: Trie -> String -> String -> (String,[(Attr,String)]) +apply (Trie (_,res)) [] inp = (inp,res) +apply (Trie (map,_)) (s:ss) inp + = case map ! s of + Just trie -> apply trie ss inp + Nothing -> (inp,[]) + +-- Composite analysis (Huet's unglue algorithm) +-- only legaldecompositions are accepted. +-- With legal means that the composite forms are ordered correctly +-- with respect to the attributes W,P and WP. + +-- Composite analysis + +testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])] + +decompose :: Trie -> String -> [String] +decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie + +-- The function legal checks if the decomposition is in fact a possible one. + +legal :: Trie -> [String] -> [String] +legal _ [] = [] +legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] + where + test [] = False + test [xs] = elem atW xs || elem atWP xs + test (xs:xss) = (elem atP xs || elem atWP xs) && test xss + +react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] +react input output back occ (Trie (arcs,res)) init = + case res of -- Accept = non-empty res. + [] -> continue back + _ -> let pushout = (occ:output) + in case input of + [] -> reverse $ map reverse pushout + _ -> let pushback = ((input,pushout):back) + in continue pushback + where continue cont = case input of + [] -> backtrack cont init + (l:rest) -> case arcs ! l of + Just trie -> + react rest output cont (l:occ) trie init + Nothing -> backtrack cont init + +backtrack :: [(String,[String])] -> Trie -> [String] +backtrack [] _ = [] +backtrack ((input,output):back) trie + = react input output back [] trie trie + +{- +-- The function legal checks if the decomposition is in fact a possible one. +legal :: Trie -> [String] -> [String] +legal _ [] = [] +legal trie input + | test $ + map ((map fst).snd.(trieLookup trie)) input = input + | otherwise = [] + where -- test checks that the Attrs are in the correct order. + test [] = False -- This case should never happen. + test [xs] = elem W xs || elem WP xs + test (xs:xss) = (elem P xs || elem WP xs) && test xss +-} diff --git a/src-3.0/GF/Data/Trie2.hs b/src-3.0/GF/Data/Trie2.hs new file mode 100644 index 000000000..36fcc3221 --- /dev/null +++ b/src-3.0/GF/Data/Trie2.hs @@ -0,0 +1,120 @@ +---------------------------------------------------------------------- +-- | +-- Module : Trie2 +-- Maintainer : Markus Forsberg +-- Stability : Stable +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/04/21 16:22:10 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.7 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Data.Trie2 ( + tcompile, + collapse, + Trie, + trieLookup, + decompose, + --- Attr, atW, atP, atWP, + emptyTrie + ) where + +import GF.Data.Map +import Data.List + +newtype TrieT a b = TrieT ([(a,TrieT a b)],[b]) + +newtype Trie a b = Trie (Map a (Trie a b), [b]) + +emptyTrieT = TrieT ([],[]) + +emptyTrie :: Trie a b +emptyTrie = Trie (empty,[]) + +optimize :: (Ord a,Eq b) => TrieT a b -> Trie a b +optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, + nub res) --- nub by AR + +collapse :: Ord a => Trie a b -> [([a],[b])] +collapse trie = collapse' trie [] + where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))] + else (reverse s,(x:xs)): + concat [ collapse' trie (c:s) | (c,trie) <- flatten map] + collapse' (Trie (map,[])) s + = concat [ collapse' trie (c:s) | (c,trie) <- flatten map] + +tcompile :: (Ord a,Eq b) => [([a],[b])] -> Trie a b +tcompile xs = optimize $ build xs emptyTrieT + +build :: Ord a => [([a],[b])] -> TrieT a b -> TrieT a b +build [] trie = trie +build (x:xs) trie = build xs (insert x trie) + where + insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) + insert ((s:ss),ys) (TrieT (xs,res)) + = case (span (\(s',_) -> s' /= s) xs) of + (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrieT)):xs),res) + (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) + +trieLookup :: Ord a => Trie a b -> [a] -> ([a],[b]) +trieLookup trie s = apply trie s s + +apply :: Ord a => Trie a b -> [a] -> [a] -> ([a],[b]) +apply (Trie (_,res)) [] inp = (inp,res) +apply (Trie (map,_)) (s:ss) inp + = case map ! s of + Just trie -> apply trie ss inp + Nothing -> (inp,[]) + +----------------------------- +-- from Trie for strings; simplified for GF by making binding always possible (AR) + +decompose :: Ord a => Trie a b -> [a] -> [[a]] +decompose trie sentence = backtrack [(sentence,[])] trie + +react :: Ord a => [a] -> [[a]] -> [([a],[[a]])] -> + [a] -> Trie a b -> Trie a b -> [[a]] +-- String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] +react input output back occ (Trie (arcs,res)) init = + case res of -- Accept = non-empty res. + [] -> continue back + _ -> let pushout = (occ:output) + in case input of + [] -> reverse $ map reverse pushout + _ -> let pushback = ((input,pushout):back) + in continue pushback + where continue cont = case input of + [] -> backtrack cont init + (l:rest) -> case arcs ! l of + Just trie -> + react rest output cont (l:occ) trie init + Nothing -> backtrack cont init + +backtrack :: Ord a => [([a],[[a]])] -> Trie a b -> [[a]] +backtrack [] _ = [] +backtrack ((input,output):back) trie + = react input output back [] trie trie + + +{- so this is not needed from the original +type Attr = Int + +atW, atP, atWP :: Attr +(atW,atP,atWP) = (0,1,2) + +decompose :: Ord a => Trie a (Int,b) -> [a] -> [[a]] +decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie + +-- The function legal checks if the decomposition is in fact a possible one. + +legal :: Ord a => Trie a (Int,b) -> [[a]] -> [[a]] +legal _ [] = [] +legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] + where + test [] = False + test [xs] = elem atW xs || elem atWP xs + test (xs:xss) = (elem atP xs || elem atWP xs) && test xss +-} diff --git a/src-3.0/GF/Data/Utilities.hs b/src-3.0/GF/Data/Utilities.hs new file mode 100644 index 000000000..74d3ef81e --- /dev/null +++ b/src-3.0/GF/Data/Utilities.hs @@ -0,0 +1,190 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Data/XML.hs b/src-3.0/GF/Data/XML.hs new file mode 100644 index 000000000..a1807adcc --- /dev/null +++ b/src-3.0/GF/Data/XML.hs @@ -0,0 +1,57 @@ +---------------------------------------------------------------------- +-- | +-- Module : XML +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- Utilities for creating XML documents. +----------------------------------------------------------------------------- + +module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where + +import GF.Data.Utilities + +data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty + deriving (Ord,Eq,Show) + +type Attr = (String,String) + +comments :: [String] -> [XML] +comments = map Comment + +showXMLDoc :: XML -> String +showXMLDoc xml = showsXMLDoc xml "" + +showsXMLDoc :: XML -> ShowS +showsXMLDoc xml = showString header . showsXML xml + where header = "" + +showsXML :: XML -> ShowS +showsXML (Data s) = showString s +showsXML (CData s) = showString "" +showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>" +showsXML (Tag t as cs) = + showChar '<' . showString t . showsAttrs as . showChar '>' + . concatS (map showsXML cs) . showString "' +showsXML (Comment c) = showString "" +showsXML (Empty) = id + +showsAttrs :: [Attr] -> ShowS +showsAttrs = concatS . map (showChar ' ' .) . map showsAttr + +showsAttr :: Attr -> ShowS +showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\"" + +escape :: String -> String +escape = concatMap escChar + where + escChar '<' = "<" + escChar '>' = ">" + escChar '&' = "&" + escChar '"' = """ + escChar c = [c] + +bottomUpXML :: (XML -> XML) -> XML -> XML +bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs)) +bottomUpXML f x = f x diff --git a/src-3.0/GF/Data/Zipper.hs b/src-3.0/GF/Data/Zipper.hs new file mode 100644 index 000000000..a4491f76e --- /dev/null +++ b/src-3.0/GF/Data/Zipper.hs @@ -0,0 +1,257 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/AbsCompute.hs b/src-3.0/GF/Devel/AbsCompute.hs new file mode 100644 index 000000000..a55fbc83f --- /dev/null +++ b/src-3.0/GF/Devel/AbsCompute.hs @@ -0,0 +1,145 @@ +---------------------------------------------------------------------- +-- | +-- Module : AbsCompute +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/02 20:50:19 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.8 $ +-- +-- computation in abstract syntax w.r.t. explicit definitions. +-- +-- old GF computation; to be updated +----------------------------------------------------------------------------- + +module GF.Devel.AbsCompute (LookDef, + compute, + computeAbsTerm, + computeAbsTermIn, + beta + ) where + +import GF.Data.Operations + +import GF.Grammar.Abstract +import GF.Grammar.PrGrammar +import GF.Grammar.LookAbs +import GF.Devel.Compute + +import Debug.Trace +import Data.List(intersperse) +import Control.Monad (liftM, liftM2) + +-- for debugging +tracd m t = t +-- tracd = trace + +compute :: GFCGrammar -> Exp -> Err Exp +compute = computeAbsTerm + +computeAbsTerm :: GFCGrammar -> Exp -> Err Exp +computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] + +-- | a hack to make compute work on source grammar as well +type LookDef = Ident -> Ident -> Err (Maybe Term) + +computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp +computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where + compt vv t = case t of +-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) +-- Abs x b -> liftM (Abs x) (compt (x:vv) b) + _ -> do + let t' = beta vv t + (yy,f,aa) <- termForm t' + let vv' = yy ++ vv + aa' <- mapM (compt vv') aa + case look f of + Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $ + case findMatch eqs aa' of + Ok (d,g) -> do + --- let (xs,ts) = unzip g + --- ts' <- alphaFreshAll vv' ts + let g' = g --- zip xs ts' + d' <- compt vv' $ substTerm vv' g' d + tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' + _ -> tracd ("no match" +++ prt t') $ + do + let v = mkApp f aa' + return $ mkAbs yy $ v + Just d -> tracd ("define" +++ prt t') $ do + da <- compt vv' $ mkApp d aa' + return $ mkAbs yy $ da + _ -> do + let t2 = mkAbs yy $ mkApp f aa' + tracd ("not defined" +++ prt_ t2) $ return t2 + + look t = case t of + (Q m f) -> case lookd m f of + Ok (Just EData) -> Nothing -- canonical --- should always be QC + Ok md -> md + _ -> Nothing + Eqs _ -> return t ---- for nested fn + _ -> Nothing + +beta :: [Ident] -> Exp -> Exp +beta vv c = case c of + Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) + App f a -> + let (a',f') = (beta vv a, beta vv f) in + case f' of + Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) + _ -> (if a'==a && f'==f then id else beta vv) $ App f' a' + Prod x a b -> Prod x (beta vv a) (beta (x:vv) b) + Abs x b -> Abs x (beta (x:vv) b) + _ -> c + +-- special version of pattern matching, to deal with comp under lambda + +findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) +findMatch cases terms = case cases of + [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + (patts,_):_ | length patts /= length terms -> + Bad ("wrong number of args for patterns :" +++ + unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) + (patts,val):cc -> case mapM tryMatch (zip patts terms) of + Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs) + _ -> findMatch cc terms + +tryMatch :: (Patt, Term) -> Err [(Ident, Term)] +tryMatch (p,t) = do + t' <- termForm t + trym p t' + where + + trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- + case (p,t') of + (PV IW, _) | notMeta t -> return [] -- optimization with wildcard + (PV x, _) | notMeta t -> return [(x,t)] + (PString s, ([],K i,[])) | s==i -> return [] + (PInt s, ([],EInt i,[])) | s==i -> return [] + (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? + (PP q p pp, ([], QC r f, tt)) | + p `eqStrIdent` f && length pp == length tt -> do + matches <- mapM tryMatch (zip pp tt) + return (concat matches) + (PP q p pp, ([], Q r f, tt)) | + p `eqStrIdent` f && length pp == length tt -> do + matches <- mapM tryMatch (zip pp tt) + return (concat matches) + (PT _ p',_) -> trym p' t' + (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) + (PAs x p',_) -> do + subst <- trym p' t' + return $ (x,t) : subst + _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t) + + notMeta e = case e of + Meta _ -> False + App f a -> notMeta f && notMeta a + Abs _ b -> notMeta b + _ -> True + + prtm p g = + prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g] diff --git a/src-3.0/GF/Devel/Arch.hs b/src-3.0/GF/Devel/Arch.hs new file mode 100644 index 000000000..dedb1b4f5 --- /dev/null +++ b/src-3.0/GF/Devel/Arch.hs @@ -0,0 +1,89 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/CheckGrammar.hs b/src-3.0/GF/Devel/CheckGrammar.hs new file mode 100644 index 000000000..0910802d1 --- /dev/null +++ b/src-3.0/GF/Devel/CheckGrammar.hs @@ -0,0 +1,1090 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/CheckM.hs b/src-3.0/GF/Devel/CheckM.hs new file mode 100644 index 000000000..d26dbc07c --- /dev/null +++ b/src-3.0/GF/Devel/CheckM.hs @@ -0,0 +1,89 @@ +---------------------------------------------------------------------- +-- | +-- Module : CheckM +-- Maintainer : (Maintainer) +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:33 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.5 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Devel.CheckM (Check, + checkError, checkCond, checkWarn, checkUpdate, checkInContext, + checkUpdates, checkReset, checkResets, checkGetContext, + checkLookup, checkStart, checkErr, checkVal, checkIn, + prtFail + ) where + +import GF.Data.Operations +import GF.Devel.Grammar.Grammar +import GF.Infra.Ident +import GF.Devel.Grammar.PrGF + +-- | the strings are non-fatal warnings +type Check a = STM (Context,[String]) a + +checkError :: String -> Check a +checkError = raise + +checkCond :: String -> Bool -> Check () +checkCond s b = if b then return () else checkError s + +-- | warnings should be reversed in the end +checkWarn :: String -> Check () +checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg)) + +checkUpdate :: Decl -> Check () +checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg)) + +checkInContext :: [Decl] -> Check r -> Check r +checkInContext g ch = do + i <- checkUpdates g + r <- ch + checkResets i + return r + +checkUpdates :: [Decl] -> Check Int +checkUpdates ds = mapM checkUpdate ds >> return (length ds) + +checkReset :: Check () +checkReset = checkResets 1 + +checkResets :: Int -> Check () +checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg)) + +checkGetContext :: Check Context +checkGetContext = do + (co,_) <- readSTM + return co + +checkLookup :: Ident -> Check Type +checkLookup x = do + co <- checkGetContext + checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co + +checkStart :: Check a -> Err (a,(Context,[String])) +checkStart c = appSTM c ([],[]) + +checkErr :: Err a -> Check a +checkErr e = stm (\s -> do + v <- e + return (v,s) + ) + +checkVal :: a -> Check a +checkVal v = return v + +prtFail :: Print a => String -> a -> Check b +prtFail s t = checkErr $ prtBad s t + +checkIn :: String -> Check a -> Check a +checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of + Bad e -> Bad $ msg ++++ e + Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where + new = take (length ws' - length ws) ws' + ws2 = [msg ++++ w | w <- new] ++ ws diff --git a/src-3.0/GF/Devel/Compile.hs b/src-3.0/GF/Devel/Compile.hs new file mode 100644 index 000000000..0655913e1 --- /dev/null +++ b/src-3.0/GF/Devel/Compile.hs @@ -0,0 +1,203 @@ +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-3.0/GF/Devel/Compile/AbsGF.hs b/src-3.0/GF/Devel/Compile/AbsGF.hs new file mode 100644 index 000000000..d053a3fa1 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/AbsGF.hs @@ -0,0 +1,274 @@ +module GF.Devel.Compile.AbsGF where + +-- Haskell module generated by the BNF converter + +newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show) +newtype LString = LString String deriving (Eq,Ord,Show) +data Grammar = + Gr [ModDef] + deriving (Eq,Ord,Show) + +data ModDef = + MModule ComplMod ModType ModBody + deriving (Eq,Ord,Show) + +data ModType = + MAbstract PIdent + | MResource PIdent + | MGrammar PIdent + | MInterface PIdent + | MConcrete PIdent PIdent + | MInstance PIdent PIdent + deriving (Eq,Ord,Show) + +data ModBody = + MBody Extend Opens [TopDef] + | MNoBody [Included] + | MWith Included [Open] + | MWithBody Included [Open] Opens [TopDef] + | MWithE [Included] Included [Open] + | MWithEBody [Included] Included [Open] Opens [TopDef] + | MReuse PIdent + | MUnion [Included] + deriving (Eq,Ord,Show) + +data Extend = + Ext [Included] + | NoExt + deriving (Eq,Ord,Show) + +data Opens = + NoOpens + | OpenIn [Open] + deriving (Eq,Ord,Show) + +data Open = + OName PIdent + | OQual PIdent PIdent + deriving (Eq,Ord,Show) + +data ComplMod = + CMCompl + | CMIncompl + deriving (Eq,Ord,Show) + +data Included = + IAll PIdent + | ISome PIdent [PIdent] + | IMinus PIdent [PIdent] + deriving (Eq,Ord,Show) + +data TopDef = + DefCat [CatDef] + | DefFun [FunDef] + | DefFunData [FunDef] + | DefDef [Def] + | DefData [DataDef] + | DefPar [ParDef] + | DefOper [Def] + | DefLincat [Def] + | DefLindef [Def] + | DefLin [Def] + | DefPrintCat [Def] + | DefPrintFun [Def] + | DefFlag [Def] + | DefPrintOld [Def] + | DefLintype [Def] + | DefPattern [Def] + | DefPackage PIdent [TopDef] + | DefVars [Def] + | DefTokenizer PIdent + deriving (Eq,Ord,Show) + +data Def = + DDecl [Name] Exp + | DDef [Name] Exp + | DPatt Name [Patt] Exp + | DFull [Name] Exp Exp + deriving (Eq,Ord,Show) + +data FunDef = + FDecl [Name] Exp + deriving (Eq,Ord,Show) + +data CatDef = + SimpleCatDef PIdent [DDecl] + | ListCatDef PIdent [DDecl] + | ListSizeCatDef PIdent [DDecl] Integer + deriving (Eq,Ord,Show) + +data DataDef = + DataDef Name [DataConstr] + deriving (Eq,Ord,Show) + +data DataConstr = + DataId PIdent + | DataQId PIdent PIdent + deriving (Eq,Ord,Show) + +data ParDef = + ParDefDir PIdent [ParConstr] + | ParDefAbs PIdent + deriving (Eq,Ord,Show) + +data ParConstr = + ParConstr PIdent [DDecl] + deriving (Eq,Ord,Show) + +data Name = + PIdentName PIdent + | ListName PIdent + deriving (Eq,Ord,Show) + +data LocDef = + LDDecl [PIdent] Exp + | LDDef [PIdent] Exp + | LDFull [PIdent] Exp Exp + deriving (Eq,Ord,Show) + +data Exp = + EPIdent PIdent + | EConstr PIdent + | ECons PIdent + | ESort Sort + | EString String + | EInt Integer + | EFloat Double + | EMeta + | EEmpty + | EData + | EList PIdent Exps + | EStrings String + | ERecord [LocDef] + | ETuple [TupleComp] + | EIndir PIdent + | ETyped Exp Exp + | EProj Exp Label + | EQConstr PIdent PIdent + | EQCons PIdent PIdent + | EApp Exp Exp + | ETable [Case] + | ETTable Exp [Case] + | EVTable Exp [Exp] + | ECase Exp [Case] + | EVariants [Exp] + | EPre Exp [Altern] + | EStrs [Exp] + | EPatt Patt + | EPattType Exp + | ESelect Exp Exp + | ETupTyp Exp Exp + | EExtend Exp Exp + | EGlue Exp Exp + | EConcat Exp Exp + | EAbstr [Bind] Exp + | ECTable [Bind] Exp + | EProd Decl Exp + | ETType Exp Exp + | ELet [LocDef] Exp + | ELetb [LocDef] Exp + | EWhere Exp [LocDef] + | EEqs [Equation] + | EExample Exp String + | ELString LString + | ELin PIdent + deriving (Eq,Ord,Show) + +data Exps = + NilExp + | ConsExp Exp Exps + deriving (Eq,Ord,Show) + +data Patt = + PChar + | PChars String + | PMacro PIdent + | PM PIdent PIdent + | PW + | PV PIdent + | PCon PIdent + | PQ PIdent PIdent + | PInt Integer + | PFloat Double + | PStr String + | PR [PattAss] + | PTup [PattTupleComp] + | PC PIdent [Patt] + | PQC PIdent PIdent [Patt] + | PDisj Patt Patt + | PSeq Patt Patt + | PRep Patt + | PAs PIdent Patt + | PNeg Patt + deriving (Eq,Ord,Show) + +data PattAss = + PA [PIdent] Patt + deriving (Eq,Ord,Show) + +data Label = + LPIdent PIdent + | LVar Integer + deriving (Eq,Ord,Show) + +data Sort = + Sort_Type + | Sort_PType + | Sort_Tok + | Sort_Str + | Sort_Strs + deriving (Eq,Ord,Show) + +data Bind = + BPIdent PIdent + | BWild + deriving (Eq,Ord,Show) + +data Decl = + DDec [Bind] Exp + | DExp Exp + deriving (Eq,Ord,Show) + +data TupleComp = + TComp Exp + deriving (Eq,Ord,Show) + +data PattTupleComp = + PTComp Patt + deriving (Eq,Ord,Show) + +data Case = + Case Patt Exp + deriving (Eq,Ord,Show) + +data Equation = + Equ [Patt] Exp + deriving (Eq,Ord,Show) + +data Altern = + Alt Exp Exp + deriving (Eq,Ord,Show) + +data DDecl = + DDDec [Bind] Exp + | DDExp Exp + deriving (Eq,Ord,Show) + +data OldGrammar = + OldGr Include [TopDef] + deriving (Eq,Ord,Show) + +data Include = + NoIncl + | Incl [FileName] + deriving (Eq,Ord,Show) + +data FileName = + FString String + | FPIdent PIdent + | FSlash FileName + | FDot FileName + | FMinus FileName + | FAddId PIdent FileName + deriving (Eq,Ord,Show) + diff --git a/src-3.0/GF/Devel/Compile/CheckGrammar.hs b/src-3.0/GF/Devel/Compile/CheckGrammar.hs new file mode 100644 index 000000000..30ea0a70e --- /dev/null +++ b/src-3.0/GF/Devel/Compile/CheckGrammar.hs @@ -0,0 +1,1089 @@ +---------------------------------------------------------------------- +-- | +-- Module : CheckGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.31 $ +-- +-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 -- 6/12/2007 +-- +-- type checking also does the following modifications: +-- +-- - types of operations and local constants are inferred and put in place +-- +-- - both these types and linearization types are computed +-- +-- - tables are type-annotated +-- +-- - overloading is resolved +----------------------------------------------------------------------------- + +module GF.Devel.Compile.CheckGrammar ( + showCheckModule, + justCheckLTerm, + allOperDependencies, + topoSortOpers + ) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.PrGF +import GF.Devel.Grammar.Lookup + +import GF.Infra.Ident + +--import GF.Grammar.Refresh ---- + +--import GF.Grammar.TypeCheck +--import GF.Grammar.Values (cPredefAbs) --- + + +--import GF.Grammar.LookAbs +--import GF.Grammar.ReservedWords ---- +import GF.Devel.Grammar.PatternMatch (testOvershadow) +import GF.Devel.Grammar.AppPredefined +--import GF.Grammar.Lockfield (isLockLabel) + +import GF.Devel.CheckM + +import GF.Data.Operations + +import Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Monad +import Debug.Trace --- + + +showCheckModule :: GF -> SourceModule -> Err (SourceModule,String) +showCheckModule mos m = do + (st,(_,msg)) <- checkStart $ checkModule mos m + return (st, unlines $ reverse msg) + +checkModule :: GF -> SourceModule -> Check SourceModule +checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do + let gr = gf0 {gfmodules = Map.insert name mo (gfmodules gf0)} + ---- checkRestrictedInheritance gr (name, mo) + mo1 <- case mtype mo of + MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo + MTGrammar -> entryOpModule (checkResInfo gr name) mo + + MTConcrete aname -> do + checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo + abs <- checkErr $ lookupModule gr aname + mo1 <- checkCompleteGrammar abs mo + entryOpModule (checkCncInfo gr name (aname,abs)) mo1 + + MTInterface -> entryOpModule (checkResInfo gr name) mo + + MTInstance iname -> do + intf <- checkErr $ lookupModule gr iname + entryOpModule (checkResInfo gr name) mo + + return $ (name, mo1) + +{- ---- +-- check if restricted inheritance modules are still coherent +-- i.e. that the defs of remaining names don't depend on omitted names +---checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () +checkRestrictedInheritance mos (name,mo) = do + let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. + let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] + -- the restr. modules themself, with restr. infos + mapM_ checkRem mrs + where + checkRem ((i,m),mi) = do + let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) + let incld c = Set.member c (Set.fromList incl) + let illegal c = Set.member c (Set.fromList excl) + let illegals = [(f,is) | + (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] + case illegals of + [] -> return () + cs -> fail $ "In inherited module" +++ prt i ++ + ", dependence of excluded constants:" ++++ + unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | + (f,is) <- cs] + allDeps = ---- transClosure $ Map.fromList $ + concatMap (allDependencies (const True)) + [jments m | (_,ModMod m) <- mos] + transClosure ds = ds ---- TODO: check in deeper modules +-} + + +-- | check if a term is typable +justCheckLTerm :: GF -> Term -> Err Term +justCheckLTerm src t = do + ((t',_),_) <- checkStart (inferLType src t) + return t' + +checkAbsInfo :: GF -> Ident -> Judgement -> Check Judgement +checkAbsInfo st m info = return info ---- + +{- +checkAbsInfo st m (c,info) = do +---- checkReservedId c + case info of + AbsCat (Yes cont) _ -> mkCheck "category" $ + checkContext st cont ---- also cstrs + AbsFun (Yes typ0) md -> do + typ <- compAbsTyp [] typ0 -- to calculate let definitions + mkCheck "type of function" $ checkTyp st typ + md' <- case md of + Yes d -> do + let d' = elimTables d + mkCheckWarn "definition of function" $ checkEquation st (m,c) d' + return $ Yes d' + _ -> return md + return $ (c,AbsFun (Yes typ) md') + _ -> return (c,info) + where + mkCheck cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + ---- temporary solution when tc of defs is incomplete + mkCheckWarn cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) + compAbsTyp g t = case t of + Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g + Let (x,(_,a)) b -> do + a' <- compAbsTyp g a + compAbsTyp ((x, a'):g) b + Prod x a b -> do + a' <- compAbsTyp g a + b' <- compAbsTyp ((x,Vr x):g) b + return $ Prod x a' b' + Abs _ _ -> return t + _ -> composOp (compAbsTyp g) t + + elimTables e = case e of + S t a -> elimSel (elimTables t) (elimTables a) + T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] + _ -> composSafeOp elimTables e + elimPatt p = case p of + PR lps -> map snd lps + _ -> [p] + elimSel t a = case a of + R fs -> mkApp t (map (snd . snd) fs) + _ -> mkApp t [a] +-} + + +checkCompleteGrammar :: Module -> Module -> Check Module +checkCompleteGrammar abs cnc = do + let js = mjments cnc + let fs = Map.assocs $ mjments abs + js' <- foldM checkOne js fs + return $ cnc {mjments = js'} + where + checkOne js i@(c, ju) = case jform ju of + JFun -> case Map.lookup c js of + Just j | jform j == JLin -> return js + _ -> do + checkWarn $ "WARNING: no linearization of" +++ prt c + return js + JCat -> case Map.lookup c js of + Just j | jform ju == JLincat -> return js + _ -> do ---- TODO: other things to check here + checkWarn $ + "Warning: no linearization type for" +++ prt c ++ + ", inserting default {s : Str}" + return $ Map.insert c (cncCat defLinType) js + _ -> return js + +checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement +checkResInfo gr mo c info = do + ---- checkReservedId c + trace (show info) (return ()) + case jform info of + JOper -> chIn "operation" $ case (jtype info, jdef info) of + _ | isConstructor info -> return info + (_,Meta _) -> do + checkWarn "No definition given to oper" + return info + (Meta _,de) -> do + (de',ty') <- infer de + ---- trace ("inferred" +++ prt de' +++ ":" +++ prt ty') $ + return (resOper ty' de') + (ty, de) -> do + ty' <- check ty typeType >>= comp . fst + (de',_) <- check de ty' + return (resOper ty' de') +{- ---- + ResOverload tysts -> chIn "overloading" $ do + tysts' <- mapM (uncurry $ flip check) tysts + let tysts2 = [(y,x) | (x,y) <- tysts'] + --- this can only be a partial guarantee, since matching + --- with value type is only possible if expected type is given + checkUniq $ + sort [t : map snd xs | (x,_) <- tysts2, let (xs,t) = prodForm x] + return (c,ResOverload tysts2) +-} +{- ---- + ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do +---- mapM ((mapM (computeLType gr . snd)) . snd) pcs + mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs + ts <- checkErr $ lookupParamValues gr mo c + return (c,ResParam (Yes (pcs, Just ts))) +-} + _ -> return info + where + infer = inferLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + comp = computeLType gr + + checkUniq xss = case xss of + x:y:xs + | x == y -> raise $ "ambiguous for argument list" +++ + unwords (map (prtType gr) x) + | otherwise -> checkUniq $ y:xs + _ -> return () + + +checkCncInfo :: GF -> Ident -> SourceModule -> + Ident -> Judgement -> Check Judgement +checkCncInfo gr cnc (a,abs) c info = do + ---- checkReservedId c + case jform info of + JFun -> chIn "linearization of" $ do + typ <- checkErr $ lookupFunType gr a c + cat0 <- checkErr $ valCat typ + (cont,val) <- linTypeOfType gr cnc typ -- creates arg vars + let lintyp = mkFunType (map snd cont) val + (trm',_) <- check (jdef info) lintyp -- erases arg vars + checkPrintname gr (jprintname info) + cat <- return $ snd cat0 + return (info {jdef = trm'}) + ---- return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) + -- cat for cf, typ for pe + + JCat -> chIn "linearization type of" $ do + checkErr $ lookupCatContext gr a c + typ' <- checkIfLinType gr (jtype info) + {- ---- + mdef' <- case mdef of + Yes def -> do + (def',_) <- checkLType gr def (mkFunType [typeStr] typ) + return $ Yes def' + _ -> return mdef + -} + checkPrintname gr (jprintname info) + return (info {jtype = typ'}) + + _ -> checkResInfo gr cnc c info + + where + env = gr + infer = inferLType gr + comp = computeLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + + +checkIfParType :: GF -> Type -> Check () +checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) + where + isParType ty = True ---- +{- case ty of + Cn typ -> case lookupConcrete st typ of + Ok (CncParType _ _ _) -> True + Ok (CncOper _ ty' _) -> isParType ty' + _ -> False + Q p t -> case lookupInPackage st (p,t) of + Ok (CncParType _ _ _) -> True + _ -> False + RecType r -> all (isParType . snd) r + _ -> False +-} + +{- ---- +checkIfStrType :: SourceGrammar -> Type -> Check () +checkIfStrType st typ = case typ of + Table arg val -> do + checkIfParType st arg + checkIfStrType st val + _ | typ == typeStr -> return () + _ -> prtFail "not a string type" typ +-} + +checkIfLinType :: GF -> Type -> Check Type +checkIfLinType st typ0 = do + typ <- computeLType st typ0 + case typ of + RecType r -> return () + _ -> prtFail "a linearization type must be a record type instead of" typ + return typ + +computeLType :: GF -> Type -> Check Type +computeLType gr t = do + g0 <- checkGetContext + let g = [(x, Vr x) | (x,_) <- g0] + checkInContext g $ comp t + where + comp ty = case ty of + + App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed + Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed + Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed + Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed + + Q m c | elem c [cPredef,cPredefAbs] -> return ty + Q m c | elem c [identC "Int"] -> + return $ defLinType +---- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in +---- RecType [ +---- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)] + Q m c | elem c [identC "Float",identC "String"] -> return defLinType ---- + + Q m ident -> checkIn ("module" +++ prt m) $ do + ty' <- checkErr (lookupOperDef gr m ident) + if ty' == ty then return ty else comp ty' --- is this necessary to test? + + Vr ident -> checkLookup ident -- never needed to compute! + + App f a -> do + f' <- comp f + a' <- comp a + case f' of + Abs x b -> checkInContext [(x,a')] $ comp b + _ -> return $ App f' a' + + Prod x a b -> do + a' <- comp a + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Prod x a' b' + + Abs x b -> do + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Abs x b' + + ExtR r s -> do + r' <- comp r + s' <- comp s + case (r',s') of + (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp + _ -> return $ ExtR r' s' + + RecType fs -> do + let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs + liftM RecType $ mapPairsM comp fs' + + _ | ty == typeTok -> return typeStr ---- deprecated + _ | isPredefConstant ty -> return ty + + _ -> composOp comp ty + +checkPrintname :: GF -> Term -> Check () +---- checkPrintname st (Yes t) = checkLType st t typeStr >> return () +checkPrintname _ _ = return () + +{- ---- +-- | for grammars obtained otherwise than by parsing ---- update!! +checkReservedId :: Ident -> Check () +checkReservedId x = let c = prt x in + if isResWord c + then checkWarn ("Warning: reserved word used as identifier:" +++ c) + else return () +-} + +-- to normalize records and record types +labelIndex :: Type -> Label -> Int +labelIndex ty lab = case ty of + RecType ts -> maybe (error ("label index"+++ prt lab)) id $ lookup lab $ labs ts + _ -> error $ "label index" +++ prt ty + where + labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] + +-- the underlying algorithms + +inferLType :: GF -> Term -> Check (Term, Type) +inferLType gr trm = case trm of + + Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + Q m ident -> checks [ + termWith trm $ checkErr (lookupOperType gr m ident) >>= comp + , + checkErr (lookupOperDef gr m ident) >>= infer + , +{- + do + over <- getOverload gr Nothing trm + case over of + Just trty -> return trty + _ -> prtFail "not overloaded" trm + , +-} + prtFail "cannot infer type of constant" trm + ] + + QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + QC m ident -> checks [ + termWith trm $ checkErr (lookupOperType gr m ident) >>= comp +-- ,checkErr (lookupOperDef gr m ident) >>= infer +-- ,prtFail "cannot infer type of canonical constant" trm + ] + + Val ty i -> termWith trm $ return ty + + Vr ident -> termWith trm $ checkLookup ident + + Typed e t -> do + t' <- comp t + check e t' + return (e,t') + + App f a -> do + over <- getOverload gr Nothing trm + case over of + Just trty -> return trty + _ -> do + (f',fty) <- infer f + fty' <- comp fty + case fty' of + Prod z arg val -> do + a' <- justCheck a arg + ty <- if isWildIdent z + then return val + else substituteLType [(z,a')] val + return (App f' a',ty) + _ -> raise ("function type expected for"+++ + prt f +++"instead of" +++ prtType env fty) + + S f x -> do + (f', fty) <- infer f + case fty of + Table arg val -> do + x'<- justCheck x arg + return (S f' x', val) + _ -> prtFail "table lintype expected for the table in" trm + + P t i -> do + (t',ty) <- infer t --- ?? + ty' <- comp ty +----- let tr2 = PI t' i (labelIndex ty' i) + let tr2 = P t' i + termWith tr2 $ checkErr $ case ty' of + RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ + lookup i ts + _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' + PI t i _ -> infer $ P t i + + R r -> do + let (ls,fs) = unzip r + fsts <- mapM inferM fs + let ts = [ty | (Just ty,_) <- fsts] + checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) + return $ (R (zip ls fsts), RecType (zip ls ts)) + + T (TTyped arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T (TComp arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T ti pts -> do -- tries to guess: good in oper type inference + let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] + case pts' of + [] -> prtFail "cannot infer table type of" trm +---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] + _ -> do + (arg,val) <- checks $ map (inferCase Nothing) pts' + check trm (Table arg val) + V arg pts -> do + (_,val) <- checks $ map infer pts + return (trm, Table arg val) + + K s -> do + if elem ' ' s + then checkWarn ("WARNING: space in token \"" ++ s ++ + "\". Lexical analysis may fail.") + else return () + return (trm, typeStr) + + EInt i -> return (trm, typeInt) + + EFloat i -> return (trm, typeFloat) + + Empty -> return (trm, typeStr) + + EParam _ cos -> return (trm, typePType) ---- check cos + + C s1 s2 -> + check2 (flip justCheck typeStr) C s1 s2 typeStr + + Glue s1 s2 -> + check2 (flip justCheck typeStr) Glue s1 s2 typeStr + +---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 +---- Strs (Cn (IC "#conflict") : ts) -> do +---- trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) +-- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) +-- infer $ head ts + + + Alts (t,aa) -> do + t' <- justCheck t typeStr + aa' <- flip mapM aa (\ (c,v) -> do + c' <- justCheck c typeStr + v' <- justCheck v typeStr + return (c',v')) + return (Alts (t',aa'), typeStr) + + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM (flip justCheck typeType) ts + return (RecType (zip ls ts'), typeType) + + ExtR r s -> do + (r',rT) <- infer r + rT' <- comp rT + (s',sT) <- infer s + sT' <- comp sT + + let trm' = ExtR r' s' + ---- trm' <- checkErr $ plusRecord r' s' + case (rT', sT') of + (RecType rs, RecType ss) -> do + rt <- checkErr $ plusRecType rT' sT' + check trm' rt ---- return (trm', rt) + _ | rT' == typeType && sT' == typeType -> return (trm', typeType) + _ -> prtFail "records or record types expected in" trm + + Sort _ -> + termWith trm $ return typeType + + Prod x a b -> do + a' <- justCheck a typeType + b' <- checkInContext [(x,a')] $ justCheck b typeType + return (Prod x a' b', typeType) + + Table p t -> do + p' <- justCheck p typeType --- check p partype! + t' <- justCheck t typeType + return $ (Table p' t', typeType) + + FV vs -> do + (_,ty) <- checks $ map infer vs +--- checkIfComplexVariantType trm ty + check trm ty + + EPattType ty -> do + ty' <- justCheck ty typeType + return (ty',typeType) + EPatt p -> do + ty <- inferPatt p + return (trm, EPattType ty) + _ -> prtFail "cannot infer lintype of" trm + + where + env = gr + infer = inferLType env + comp = computeLType env + + check = checkLType env + + isPredef m = elem m [cPredef,cPredefAbs] + + justCheck ty te = check ty te >>= return . fst + + -- for record fields, which may be typed + inferM (mty, t) = do + (t', ty') <- case mty of + Just ty -> check ty t + _ -> infer t + return (Just ty',t') + + inferCase mty (patt,term) = do + arg <- maybe (inferPatt patt) return mty + cont <- pattContext env arg patt + i <- checkUpdates cont + (_,val) <- infer term + checkResets i + return (arg,val) + isConstPatt p = case p of + PC _ ps -> True --- all isConstPatt ps + PP _ _ ps -> True --- all isConstPatt ps + PR ps -> all (isConstPatt . snd) ps + PT _ p -> isConstPatt p + PString _ -> True + PInt _ -> True + PFloat _ -> True + PSeq p q -> isConstPatt p || isConstPatt q + PAlt p q -> isConstPatt p || isConstPatt q + PRep p -> isConstPatt p + PNeg p -> isConstPatt p + PAs _ p -> isConstPatt p + PChar -> True + PChars _ -> True + _ -> False + + inferPatt p = case p of + PP q c ps | q /= cPredef -> + checkErr $ lookupOperType gr q c >>= return . snd . prodForm + PAs _ p -> inferPatt p + PNeg p -> inferPatt p + PAlt p q -> checks [inferPatt p, inferPatt q] + PSeq _ _ -> return $ typeStr + PRep _ -> return $ typeStr + PChar -> return $ typeStr + PChars _ -> return $ typeStr + _ -> infer (patt2term p) >>= return . snd + + +-- type inference: Nothing, type checking: Just t +-- the latter permits matching with value type +getOverload :: GF -> Maybe Type -> Term -> Check (Maybe (Term,Type)) +getOverload env@gr mt t = case appForm t of + (f@(Q m c), ts) -> case lookupOverload gr m c of + Ok typs -> do + ttys <- mapM infer ts + v <- matchOverload f typs ttys + return $ Just v + _ -> return Nothing + _ -> return Nothing + where + infer = inferLType env + matchOverload f typs ttys = do + let (tts,tys) = unzip ttys + let vfs = lookupOverloadInstance tys typs + + case [vf | vf@(v,f) <- vfs, matchVal mt v] of + [(val,fun)] -> return (mkApp fun tts, val) + [] -> raise $ "no overload instance of" +++ prt f +++ + "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ + unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ + maybe [] (("with value type" +++) . prtType env) mt + + ---- ++++ "DEBUG" +++ unwords (map show tys) +++ ";" + ---- ++++ unlines (map (show . fst) typs) ---- + + vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of + [(val,fun)] -> do + checkWarn $ "WARNING: overloading of" +++ prt f +++ + "resolved by excluding partial applications:" ++++ + unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] + return (mkApp fun tts, val) + + _ -> raise $ "ambiguous overloading of" +++ prt f +++ + "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ + unlines [prtType env ty | (ty,_) <- vfs'] + + matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where + unlocked = case v of + RecType fs -> [Just $ RecType $ fs] ---- filter (not . isLockLabel . fst) fs] + _ -> [] + ---- TODO: accept subtypes + ---- TODO: use a trie + lookupOverloadInstance tys typs = + [(mkFunType rest val, t) | + let lt = length tys, + (ty,(val,t)) <- typs, length ty >= lt, + let (pre,rest) = splitAt lt ty, + pre == tys + ] + + noProd ty = case ty of + Prod _ _ _ -> False + _ -> True + +checkLType :: GF -> Term -> Type -> Check (Term, Type) +checkLType env trm typ0 = do + trace (show trm) (return ()) + + typ <- comp typ0 + + case trm of + + Abs x c -> do + case typ of + Prod z a b -> do + checkUpdate (x,a) + (c',b') <- if isWildIdent z + then check c b + else do + b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b + check c b' + checkReset + return $ (Abs x c', Prod x a b') + _ -> raise $ "product expected instead of" +++ prtType env typ + + App f a -> do + over <- getOverload env (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + + Q _ _ -> do + over <- getOverload env (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + + EData -> return (trm,typ) + + T _ [] -> + prtFail "found empty table in type" typ + T _ cs -> case typ of + Table arg val -> do + case allParamValues env arg of + Ok vs -> do + let ps0 = map fst cs + ps <- return [] ---- checkErr $ testOvershadow ps0 vs + if null ps + then return () + else checkWarn $ "WARNING: patterns never reached:" + ---- +++ concat (intersperse ", " (map prt ps)) + + _ -> return () -- happens with variable types + cs' <- mapM (checkCase arg val) cs + return (T (TTyped arg) cs', typ) + _ -> raise $ "table type expected for table instead of" +++ prtType env typ + + R r -> case typ of --- why needed? because inference may be too difficult + RecType rr -> do + let (ls,_) = unzip rr -- labels of expected type + fsts <- mapM (checkM r) rr -- check that they are found in the record + return $ (R fsts, typ) -- normalize record + + _ -> prtFail "record type expected in type checking instead of" typ + + ExtR r s -> case typ of + _ | typ == typeType -> do + trm' <- comp trm + case trm' of + RecType _ -> termWith trm $ return typeType + ExtR (Vr _) (RecType _) -> termWith trm $ return typeType + -- ext t = t ** ... + _ -> prtFail "invalid record type extension" trm + RecType rr -> do + (r',ty,s') <- checks [ + do (r',ty) <- infer r + return (r',ty,s) + , + do (s',ty) <- infer s + return (s',ty,r) + ] + case ty of + RecType rr1 -> do + let (rr0,rr2) = recParts rr rr1 + r2 <- justCheck r' rr0 + s2 <- justCheck s' rr2 + return $ (ExtR r2 s2, typ) + _ -> raise ("record type expected in extension of" +++ prt r +++ + "but found" +++ prt ty) + + ExtR ty ex -> do + r' <- justCheck r ty + s' <- justCheck s ex + return $ (ExtR r' s', typ) --- is this all? + + _ -> prtFail "record extension not meaningful for" typ + + FV vs -> do + ttys <- mapM (flip check typ) vs +--- checkIfComplexVariantType trm typ + return (FV (map fst ttys), typ) --- typ' ? + + S tab arg -> checks [ do + (tab',ty) <- infer tab + ty' <- comp ty + case ty' of + Table p t -> do + (arg',val) <- check arg p + checkEq typ t trm + return (S tab' arg', t) + _ -> raise $ "table type expected for applied table instead of" +++ + prtType env ty' + , do + (arg',ty) <- infer arg + ty' <- comp ty + (tab',_) <- check tab (Table ty' typ) + return (S tab' arg', typ) + ] + Let (x,(mty,def)) body -> case mty of + Just ty -> do + (def',ty') <- check def ty + checkUpdate (x,ty') + body' <- justCheck body typ + checkReset + return (Let (x,(Just ty',def')) body', typ) + _ -> do + (def',ty) <- infer def -- tries to infer type of local constant + check (Let (x,(Just ty,def')) body) typ + + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + where + cnc = env + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + checkEq = checkEqLType env + + recParts rr t = (RecType rr1,RecType rr2) where + (rr1,rr2) = partition (flip elem (map fst t) . fst) rr + + checkM rms (l,ty) = case lookup l rms of + Just (Just ty0,t) -> do + checkEq ty ty0 t + (t',ty') <- check t ty + return (l,(Just ty',t')) + Just (_,t) -> do + (t',ty') <- check t ty + return (l,(Just ty',t')) + _ -> prtFail "cannot find value for label" l + + checkCase arg val (p,t) = do + cont <- pattContext env arg p + i <- checkUpdates cont + t' <- justCheck t val + checkResets i + return (p,t') + +pattContext :: LTEnv -> Type -> Patt -> Check Context +pattContext env typ p = case p of + PV x | not (isWildIdent x) -> return [(x,typ)] + PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 + t <- checkErr $ lookupOperType cnc q c + let (cont,v) = prodForm t + checkCond ("wrong number of arguments for constructor in" +++ prt p) + (length cont == length ps) + checkEqLType env typ v (patt2term p) + mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat + PR r -> do + typ' <- computeLType env typ + case typ' of + RecType t -> do + let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] + ----- checkWarn $ prt p ++++ show pts ----- debug + mapM (uncurry (pattContext env)) pts >>= return . concat + _ -> prtFail "record type expected for pattern instead of" typ' + PT t p' -> do + checkEqLType env typ t (patt2term p') + pattContext env typ p' + + PAs x p -> do + g <- pattContext env typ p + return $ (x,typ):g + + PAlt p' q -> do + g1 <- pattContext env typ p' + g2 <- pattContext env typ q + let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] + checkCond + ("incompatible bindings of" +++ + unwords (nub (map (prt . fst) pts))+++ + "in pattern alterantives" +++ prt p) (null pts) + return g1 -- must be g1 == g2 + PSeq p q -> do + g1 <- pattContext env typ p + g2 <- pattContext env typ q + return $ g1 ++ g2 + PRep p' -> noBind typeStr p' + PNeg p' -> noBind typ p' + + _ -> return [] ---- check types! + where + cnc = env + noBind typ p' = do + co <- pattContext env typ p' + if not (null co) + then checkWarn ("no variable bound inside pattern" +++ prt p) + >> return [] + else return [] + +-- auxiliaries + +type LTEnv = GF + +termWith :: Term -> Check Type -> Check (Term, Type) +termWith t ct = do + ty <- ct + return (t,ty) + +-- | light-weight substitution for dep. types +substituteLType :: Context -> Type -> Check Type +substituteLType g t = case t of + Vr x -> return $ maybe t id $ lookup x g + _ -> composOp (substituteLType g) t + +-- | compositional check\/infer of binary operations +check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> + Term -> Term -> Type -> Check (Term,Type) +check2 chk con a b t = do + a' <- chk a + b' <- chk b + return (con a' b', t) + +checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type +checkEqLType env t u trm = do + (b,t',u',s) <- checkIfEqLType env t u trm + case b of + True -> return t' + False -> raise $ s +++ "type of" +++ prt trm +++ + ": expected:" +++ prtType env t ++++ + "inferred:" +++ prtType env u + +checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) +checkIfEqLType env t u trm = do + t' <- comp t + u' <- comp u + case t' == u' || alpha [] t' u' of + True -> return (True,t',u',[]) + -- forgive missing lock fields by only generating a warning. + --- better: use a flag to forgive? (AR 31/1/2006) + _ -> case missingLock [] t' u' of + Ok lo -> do + checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) + return (True,t',u',[]) + Bad s -> return (False,t',u',s) + + where + + -- t is a subtype of u + --- quick hack version of TC.eqVal + alpha g t u = case (t,u) of + + -- error (the empty type!) is subtype of any other type + (_,Q (IC "Predef") (IC "Error")) -> True + + -- unknown type unifies with any type ---- + (_,Meta _) -> True + + -- contravariance + (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d + + -- record subtyping + (RecType rs, RecType ts) -> all (\ (l,a) -> + any (\ (k,b) -> alpha g a b && l == k) ts) rs + (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' + (ExtR r s, t) -> alpha g r t || alpha g s t + + -- the following say that Ints n is a subset of Int and of Ints m >= n + (App (Q (IC "Predef") (IC "Ints")) (EInt n), + App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n + (App (Q (IC "Predef") (IC "Ints")) (EInt n), + Q (IC "Predef") (IC "Int")) -> True ---- check size! + + (Q (IC "Predef") (IC "Int"), ---- why this ???? AR 11/12/2005 + App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True + + ---- this should be made in Rename + (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + || m == n --- for Predef + (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + + (Table a b, Table c d) -> alpha g a c && alpha g b d + (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g + _ -> t == u + --- the following should be one-way coercions only. AR 4/1/2001 + || elem t sTypes && elem u sTypes + || (t == typeType && u == typePType) + || (u == typeType && t == typePType) + + missingLock g t u = case (t,u) of + (RecType rs, RecType ts) -> + let + ls = [l | (l,a) <- rs, + not (any (\ (k,b) -> alpha g a b && l == k) ts)] + (locks,others) = partition (const False) ls ---- isLockLabel ls + in case others of + _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) + _ -> return locks + -- contravariance + (Prod x a b, Prod y c d) -> do + ls1 <- missingLock g c a + ls2 <- missingLock g b d + return $ ls1 ++ ls2 + + _ -> Bad "" + + ---- to revise + allExtendsPlus _ n = [n] + + sTypes = [typeStr, typeString, typeTok] ---- Tok deprecated + comp = computeLType env + +-- printing a type with a lock field lock_C as C +prtType :: LTEnv -> Type -> String +prtType env ty = case ty of + RecType fs -> ---- case filter isLockLabel $ map fst fs of + ---- [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty + ---- _ -> + prtt ty + Prod x a b -> prtType env a +++ "->" +++ prtType env b + _ -> prtt ty + where + prtt t = prt t + ---- use computeLType gr to check if really equal to the cat with lock + + +-- | linearization types and defaults +linTypeOfType :: GF -> Ident -> Type -> Check (Context,Type) +linTypeOfType cnc m typ = do + (cont,cat) <- checkErr $ typeSkeleton typ + val <- lookLin cat + args <- mapM mkLinArg (zip [0..] cont) + return (args, val) + where + mkLinArg (i,(n,mc@(m,cat))) = do + val <- lookLin mc + let vars = mkRecType varLabel $ replicate n typeStr + symb = argIdent n cat i + rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ + plusRecType vars val + return (symb,rec) + lookLin (_,c) = checks [ --- rather: update with defLinType ? + checkErr (lookupLincat cnc m c) >>= computeLType cnc + ,return defLinType + ] + +-- | dependency check, detecting circularities and returning topo-sorted list + +allOperDependencies :: Ident -> Map.Map Ident Judgement -> [(Ident,[Ident])] +allOperDependencies m = allDependencies (==m) + +allDependencies :: (Ident -> Bool) -> Map.Map Ident Judgement -> [(Ident,[Ident])] +allDependencies ism b = + [(f, nub (concatMap opersIn (pts i))) | (f,i) <- Map.assocs b] + where + opersIn t = case t of + Q n c | ism n -> [c] + QC n c | ism n -> [c] + _ -> collectOp opersIn t + pts i = [jtype i, jdef i] + ---- AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual + +topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] +topoSortOpers st = do + let eops = topoTest st + either + return + (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) + eops diff --git a/src-3.0/GF/Devel/Compile/Compile.hs b/src-3.0/GF/Devel/Compile/Compile.hs new file mode 100644 index 000000000..07e059ed4 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/Compile.hs @@ -0,0 +1,205 @@ +module GF.Devel.Compile.Compile (batchCompile) where + +-- the main compiler passes +import GF.Devel.Compile.GetGrammar +import GF.Devel.Compile.Extend +import GF.Devel.Compile.Rename +import GF.Devel.Compile.CheckGrammar +import GF.Devel.Compile.Refresh +import GF.Devel.Compile.Optimize +import GF.Devel.Compile.Factorize + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Infra.Ident +import GF.Devel.Grammar.PrGF +----import GF.Devel.Grammar.Lookup +import GF.Devel.Infra.ReadFiles + +import GF.Infra.Option ---- +import GF.Data.Operations +import GF.Devel.UseIO +import GF.Devel.Arch + +import Control.Monad +import System.Directory + +batchCompile :: Options -> [FilePath] -> IO GF +batchCompile opts files = do + let defOpts = addOptions opts (options [emitCode]) + egr <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files + case egr of + Ok (_,gr) -> return gr + Bad s -> error s + +-- to output an intermediate stage +intermOut :: Options -> Option -> String -> IOE () +intermOut opts opt s = + if oElem opt opts || oElem (iOpt "show_all") opts + then + ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) + else + return () + +prMod :: SourceModule -> String +prMod = prModule + +-- | the environment +type CompileEnv = (Int,GF) + +-- | compile with one module as starting point +-- command-line options override options (marked by --#) in the file +-- As for path: if it is read from file, the file path is prepended to each name. +-- If from command line, it is used as it is. + +compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv +compileModule opts1 env file = do + opts0 <- ioeIO $ getOptionsFromFile file + let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList + let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList + let opts = addOptions opts1 opts0 + let fpath = dropFileName file + ps0 <- ioeIO $ pathListOpts opts fpath + + let ps1 = if (useFileOpt && not useLineOpt) + then (ps0 ++ map (combine fpath) ps0) + else ps0 + ps <- ioeIO $ extendPathEnv ps1 + let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) + ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- + let sgr = snd env + let rfs = [] ---- files already in memory and their read times + let file' = if useFileOpt then takeFileName file else file -- find file itself + files <- getAllFiles opts ps rfs file' + ioeIOIf $ putStrLn $ "files to read:" +++ show files ---- + let names = map justModuleName files + ioeIOIf $ putStrLn $ "modules to include:" +++ show names ---- + let sgr2 = sgr ----MGrammar [m | m@(i,_) <- modules sgr, + ---- notElem (prt i) $ map dropExtension names] + let env0 = (0,sgr2) + (e,mm) <- foldIOE (compileOne opts) env0 files + maybe (return ()) putStrLnE mm + return e + + +compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv +compileOne opts env@(_,srcgr) file = do + + let putp s = putPointE opts ("\n" ++ s) + let putpp = putPointEsil opts + let putpOpt v m act + | oElem beVerbose opts = putp v act + | oElem beSilent opts = putpp v act + | otherwise = ioeIO (putStrFlush ("\n" ++ m)) >> act + + let gf = takeExtensions file + let path = dropFileName file + let name = dropExtension file + let mos = gfmodules srcgr + + case gf of + + -- for compiled gf, read the file and update environment + -- also undo common subexp optimization, to enable normal computations + + ".gfn" -> do + sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file + let sm1 = unsubexpModule sm0 + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 + extendCompileEnv env sm + + -- for gf source, do full compilation and generate code + _ -> do + + let modu = dropExtension file + b1 <- ioeIO $ doesFileExist file + if not b1 + then compileOne opts env $ gfoFile $ modu + else do + + sm0 <- + putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ + getSourceModule opts file + (k',sm) <- compileSourceModule opts env sm0 + let sm1 = sm ---- +---- if isConcr sm then shareModule sm else sm -- cannot expand Str + if oElem (iOpt "doemit") opts + then putpp " generating code... " $ generateModuleCode opts path sm1 + else return () +---- -- sm is optimized before generation, but not in the env +---- let cm2 = unsubexpModule cm + extendCompileEnvInt env (k',sm) ---- sm1 + where + isConcr (_,mi) = case mi of +---- ModMod m -> isModCnc m && mstatus m /= MSIncomplete + _ -> False + + + +compileSourceModule :: Options -> CompileEnv -> + SourceModule -> IOE (Int,SourceModule) +compileSourceModule opts env@(k,gr) mo@(i,mi) = do + + intermOut opts (iOpt "show_gf") (prMod mo) + + let putp = putPointE opts + putpp = putPointEsil opts + stopIf n comp m = + if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return m else comp m + stopIfV v n comp m = + if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return (m,v) else comp m + + moe <- stopIf 1 (putpp " extending" . ioeErr . extendModule gr) mo + intermOut opts (iOpt "show_extend") (prMod moe) + + mor <- stopIf 2 (putpp " renaming" . ioeErr . renameModule gr) moe + intermOut opts (iOpt "show_rename") (prMod mor) + + (moc,warnings) <- + stopIfV [] 3 (putpp " type checking" . ioeErr . showCheckModule gr) mor + if null warnings then return () else putp warnings $ return () + intermOut opts (iOpt "show_typecheck") (prMod moc) + + (mox,k') <- stopIfV k 4 (putpp " refreshing " . ioeErr . refreshModule k) moc + intermOut opts (iOpt "show_refresh") (prMod mox) + + moo <- stopIf 5 (putpp " optimizing " . ioeErr . optimizeModule opts gr) mox + intermOut opts (iOpt "show_optimize") (prMod moo) + + mof <- stopIf 6 (putpp " factorizing " . ioeErr . optimizeModule opts gr) moo + intermOut opts (iOpt "show_factorize") (prMod mof) + + return (k',moo) ---- + + +generateModuleCode :: Options -> InitPath -> SourceModule -> IOE () +generateModuleCode opts path minfo@(name,info) = do + + let pname = combine path (prt name) + let minfo0 = minfo + let minfo1 = subexpModule minfo0 + let minfo2 = minfo1 + + let (file,out) = (gfoFile pname, prGF (gfModules [minfo2])) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ out + + return () ----- minfo2 + where + putp = putPointE opts + putpp = putPointEsil opts + +-- auxiliaries + +pathListOpts :: Options -> FileName -> IO [InitPath] +pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList + +----reverseModules (MGrammar ms) = MGrammar $ reverse ms + +emptyCompileEnv :: CompileEnv +emptyCompileEnv = (0,emptyGF) + +extendCompileEnvInt (_,gf) (k,(s,m)) = return (k, addModule s m gf) + +extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm) + + diff --git a/src-3.0/GF/Devel/Compile/ErrM.hs b/src-3.0/GF/Devel/Compile/ErrM.hs new file mode 100644 index 000000000..9cad4e252 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/ErrM.hs @@ -0,0 +1,26 @@ +-- BNF Converter: Error Monad +-- Copyright (C) 2004 Author: Aarne Ranta + +-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. +module GF.Devel.Compile.ErrM where + +-- the Error monad: like Maybe type with error msgs + +import Control.Monad (MonadPlus(..), liftM) + +data Err a = Ok a | Bad String + deriving (Read, Show, Eq, Ord) + +instance Monad Err where + return = Ok + fail = Bad + Ok a >>= f = f a + Bad s >>= f = Bad s + +instance Functor Err where + fmap = liftM + +instance MonadPlus Err where + mzero = Bad "Err.mzero" + mplus (Bad _) y = y + mplus x _ = x diff --git a/src-3.0/GF/Devel/Compile/Extend.hs b/src-3.0/GF/Devel/Compile/Extend.hs new file mode 100644 index 000000000..2f1aae65b --- /dev/null +++ b/src-3.0/GF/Devel/Compile/Extend.hs @@ -0,0 +1,154 @@ +---------------------------------------------------------------------- +-- | +-- Module : Extend +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 21:08:14 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.18 $ +-- +-- AR 14\/5\/2003 -- 11\/11 +-- 4/12/2007 this module is still very very messy... ---- +-- +-- The top-level function 'extendModule' +-- extends a module symbol table by indirections to the module it extends +----------------------------------------------------------------------------- + +module GF.Devel.Compile.Extend ( + extendModule + ) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.PrGF +import GF.Devel.Grammar.Lookup +import GF.Devel.Grammar.Macros + +import GF.Infra.Ident + +import GF.Data.Operations + +import Data.List (nub) +import Data.Map +import Control.Monad + +extendModule :: GF -> SourceModule -> Err SourceModule +extendModule gf nmo0 = do + (name,mo) <- rebuildModule gf nmo0 + case mtype mo of + + ---- Just to allow inheritance in incomplete concrete (which are not + ---- compiled anyway), extensions are not built for them. + ---- Should be replaced by real control. AR 4/2/2005 + MTConcrete _ | not (isCompleteModule mo) -> return (name,mo) + _ -> do + mo' <- foldM (extOne name) mo (mextends mo) + return (name, mo') + where + extOne name mo (n,cond) = do + mo0 <- lookupModule gf n + + -- test that the module types match + testErr True ---- (legalExtension mo mo0) + ("illegal extension type to module" +++ prt name) + + -- find out if the old is complete + let isCompl = isCompleteModule mo0 + + -- if incomplete, remove it from extension list --- because?? + let me' = (if isCompl then id else (Prelude.filter ((/=n) . fst))) + (mextends mo) + + -- build extension depending on whether the old module is complete + js0 <- extendMod isCompl n (isInherited cond) name (mjments mo0) (mjments mo) + + return $ mo {mextends = me', mjments = js0} + +-- | When extending a complete module: new information is inserted, +-- and the process is interrupted if unification fails. +-- If the extended module is incomplete, its judgements are just copied. +extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident -> + Map Ident Judgement -> Map Ident Judgement -> + Err (Map Ident Judgement) +extendMod isCompl name cond base old new = foldM try new $ assocs old where + try t i@(c,_) | not (cond c) = return t + try t i@(c,_) = errIn ("constant" +++ prt c) $ + tryInsert (extendAnyInfo isCompl name base) indirIf t i + indirIf = if isCompl then indirInfo name else id + +indirInfo :: Ident -> Judgement -> Judgement +indirInfo n ju = case jform ju of + JLink -> ju -- original link is passed + _ -> linkInherited (isConstructor ju) n + +extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement +extendAnyInfo isc n o i j = + errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ + unifyJudgement i j + +tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> + Map a b -> (a,b) -> Err (Map a b) +tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of + Just info0 -> do + info1 <- unif info info0 + return $ insert x info1 tree + _ -> return $ insert x (indir info) tree + +-- | rebuilding instance + interface, and "with" modules, prior to renaming. +-- AR 24/10/2003 +rebuildModule :: GF -> SourceModule -> Err SourceModule +rebuildModule gr mo@(i,mi) = case mtype mi of + + -- copy interface contents to instance + MTInstance i0 -> do + m0 <- lookupModule gr i0 + testErr (isInterface m0) ("not an interface:" +++ prt i0) + js1 <- extendMod False i0 (const True) i (mjments m0) (mjments mi) + + --- to avoid double inclusions, in instance J of I0 = J0 ** ... + case mextends mi of + [] -> return $ (i,mi {mjments = js1}) + es -> do + mes <- mapM (lookupModule gr . fst) es ---- restricted?? 12/2007 + let notInExts c _ = all (notMember c . mjments) mes + let js2 = filterWithKey notInExts js1 + return $ (i,mi { + mjments = js2 + }) + + -- copy functor contents to instantiation, and also add opens + _ -> case minstances mi of + [((ext,incl),ops)] -> do + let interfs = Prelude.map fst ops + + -- test that all interfaces are instantiated + let isCompl = Prelude.null [i | (_,i) <- minterfaces mi, notElem i interfs] + testErr isCompl ("module" +++ prt i +++ "remains incomplete") + + -- look up the functor and build new opens set + mi0 <- lookupModule gr ext + let + ops1 = nub $ + mopens mi -- own opens; N.B. mi0 has been name-resolved already + ++ ops -- instantiating opens + ++ [(n,o) | + (n,o) <- mopens mi0, notElem o interfs] -- ftor's non-if opens + ++ [(i,i) | i <- Prelude.map snd ops] ---- -- insts w. real names + + -- combine flags; new flags have priority + let fs1 = union (mflags mi) (mflags mi0) + + -- copy inherited functor judgements + let js0 = [ci | ci@(c,_) <- assocs (mjments mi0), isInherited incl c] + let js1 = fromList (assocs (mjments mi) ++ js0) + + return $ (i,mi { + mflags = fs1, + mextends = mextends mi, -- extends of instantiation + mopens = ops1, + mjments = js1 + }) + _ -> return (i,mi) + diff --git a/src-3.0/GF/Devel/Compile/Factorize.hs b/src-3.0/GF/Devel/Compile/Factorize.hs new file mode 100644 index 000000000..7386f3ed5 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/Factorize.hs @@ -0,0 +1,251 @@ +---------------------------------------------------------------------- +-- | +-- Module : OptimizeGF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:21:33 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- Optimizations on GF source code: sharing, parametrization, value sets. +-- +-- optimization: sharing branches in tables. AR 25\/4\/2003. +-- following advice of Josef Svenningsson +----------------------------------------------------------------------------- + +module GF.Devel.Compile.Factorize ( + optModule, + unshareModule, + unsubexpModule, + unoptModule, + subexpModule, + shareModule + ) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.PrGF (prt) +import qualified GF.Devel.Grammar.Macros as C + +import GF.Devel.Grammar.Lookup +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List + +optModule :: SourceModule -> SourceModule +optModule = subexpModule . shareModule + +shareModule = processModule optim + +unoptModule :: GF -> SourceModule -> SourceModule +unoptModule gr = unshareModule gr . unsubexpModule + +unshareModule :: GF -> SourceModule -> SourceModule +unshareModule gr = processModule (const (unoptim gr)) + +processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule +processModule opt (i,mo) = + (i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)}) + +shareInfo :: (Term -> Term) -> Judgement -> Judgement +shareInfo opt ju = ju {jdef = opt (jdef ju)} + +-- the function putting together optimizations +optim :: Ident -> Term -> Term +optim c = values . factor c 0 + +-- we need no counter to create new variable names, since variables are +-- local to tables ---- +-- factor parametric branches + +factor :: Ident -> Int -> Term -> Term +factor c i t = case t of + T _ [_] -> t + T _ [] -> t + T (TComp ty) cs -> + T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs] + _ -> C.composSafeOp (factor c i) t + where + + factors i psvs = -- we know psvs has at least 2 elements + let p = qqIdent c i + vs' = map (mkFun p) psvs + in if allEqs vs' + then mkCase p vs' + else psvs + + mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val + + allEqs (v:vs) = all (==v) vs + + mkCase p (v:_) = [(PV p, v)] + +--- we hope this will be fresh and don't check... + +qqIdent c i = identC ("_q_" ++ prt c ++ "__" ++ show i) + + +-- we need to replace subterms + +replace :: Term -> Term -> Term -> Term +replace old new trm = case trm of + + -- these are the important cases, since they can correspond to patterns + QC _ _ | trm == old -> new + App t ts | trm == old -> new + App t ts -> App (repl t) (repl ts) + R _ | isRec && trm == old -> new + _ -> C.composSafeOp repl trm + where + repl = replace old new + isRec = case trm of + R _ -> True + _ -> False + +-- It is very important that this is performed only after case +-- expansion since otherwise the order and number of values can +-- be incorrect. Guaranteed by the TComp flag. + +values :: Term -> Term +values t = case t of + T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization + T (TComp ty) cs -> V ty [values t | (_, t) <- cs] + T (TTyped ty) cs -> V ty [values t | (_, t) <- cs] + ---- why are these left? + ---- printing with GrammarToSource does not preserve the distinction + _ -> C.composSafeOp values t + + +-- to undo the effect of factorization + +unoptim :: GF -> Term -> Term +unoptim gr = unfactor gr + +unfactor :: GF -> Term -> Term +unfactor gr t = case t of + T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] + _ -> C.composSafeOp unfac t + where + unfac = unfactor gr + vals = err error id . allParamValues gr + restore x u t = case t of + Vr y | y == x -> u + _ -> C.composSafeOp (restore x u) t + + +---------------------------------------------------------------------- + +{- +This module implements a simple common subexpression elimination + for gfc grammars, to factor out shared subterms in lin rules. +It works in three phases: + + (1) collectSubterms collects recursively all subterms of forms table and (P x..y) + from lin definitions (experience shows that only these forms + tend to get shared) and counts how many times they occur + (2) addSubexpConsts takes those subterms t that occur more than once + and creates definitions of form "oper A''n = t" where n is a + fresh number; notice that we assume no ids of this form are in + scope otherwise + (3) elimSubtermsMod goes through lins and the created opers by replacing largest + possible subterms by the newly created identifiers + +The optimization is invoked in gf by the flag i -subs. + +If an application does not support GFC opers, the effect of this +optimization can be undone by the function unSubelimCanon. + +The function unSubelimCanon can be used to diagnostisize how much +cse is possible in the grammar. It is used by the flag pg -printer=subs. + +-} + +subexpModule :: SourceModule -> SourceModule +subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of + MTAbstract -> return (m,mo) + _ -> do + let js = listJudgements mo + (tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0) + js2 <- addSubexpConsts m tree js + return (m, mo{mjments = Map.fromList js2}) + +unsubexpModule :: SourceModule -> SourceModule +unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)}) + where + unparInfo (c, ju) = case jtype ju of + EInt 8 -> [] -- subexp-generated opers + _ -> [(c, ju {jdef = unparTerm (jdef ju)})] + unparTerm t = case t of + Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers + maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo) + _ -> C.composSafeOp unparTerm t + rebuild = Map.fromList . concat . map unparInfo . Map.assocs + +-- implementation + +type TermList = Map Term (Int,Int) -- number of occs, id +type TermM a = STM (TermList,Int) a + +addSubexpConsts :: + Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)] +addSubexpConsts mo tree lins = do + let opers = [oper id trm | (trm,(_,id)) <- list] + mapM mkOne $ opers ++ lins + where + + mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)}) + recomp f t = case Map.lookup t tree of + Just (_,id) | ident id /= f -> Q mo (ident id) + _ -> C.composSafeOp (recomp f) t + + list = Map.toList tree + + oper id trm = (ident id, resOper (EInt 8) trm) + --- impossible type encoding generated opers + +getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int)) +getSubtermsMod mo js = do + mapM (getInfo (collectSubterms mo)) js + (tree0,_) <- readSTM + return $ Map.filter (\ (nu,_) -> nu > 1) tree0 + where + getInfo get fi@(_,i) = do + get (jdef i) + return $ fi + +collectSubterms :: Ident -> Term -> TermM Term +collectSubterms mo t = case t of + App f a -> do + collect f + collect a + add t + T ty cs -> do + let (_,ts) = unzip cs + mapM collect ts + add t + V ty ts -> do + mapM collect ts + add t +---- K (KP _ _) -> add t + _ -> C.composOp (collectSubterms mo) t + where + collect = collectSubterms mo + add t = do + (ts,i) <- readSTM + let + ((count,id),next) = case Map.lookup t ts of + Just (nu,id) -> ((nu+1,id), i) + _ -> ((1, i ), i+1) + writeSTM (Map.insert t (count,id) ts, next) + return t --- only because of composOp + +ident :: Int -> Ident +ident i = identC ("_A" ++ show i) --- + diff --git a/src-3.0/GF/Devel/Compile/GF.cf b/src-3.0/GF/Devel/Compile/GF.cf new file mode 100644 index 000000000..3edbdf347 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/GF.cf @@ -0,0 +1,326 @@ +-- AR 2/5/2003, 14-16 o'clock, Torino + +-- 17/6/2007: marked with suffix --% those lines that are obsolete and +-- should not be included in documentation + +entrypoints Grammar, ModDef, + OldGrammar, --% + Exp ; -- let's see if more are needed + +comment "--" ; +comment "{-" "-}" ; + + +-- identifiers + +position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ; + +-- the top-level grammar + +Gr. Grammar ::= [ModDef] ; + +-- semicolon after module is permitted but not obligatory + +terminator ModDef "" ; +_. ModDef ::= ModDef ";" ; + +-- the individual modules + +MModule. ModDef ::= ComplMod ModType "=" ModBody ; + +MAbstract. ModType ::= "abstract" PIdent ; +MResource. ModType ::= "resource" PIdent ; +MGrammar. ModType ::= "grammar" PIdent ; +MInterface. ModType ::= "interface" PIdent ; +MConcrete. ModType ::= "concrete" PIdent "of" PIdent ; +MInstance. ModType ::= "instance" PIdent "of" PIdent ; + +MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; +MNoBody. ModBody ::= [Included] ; +MWith. ModBody ::= Included "with" [Open] ; +MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ; +MWithE. ModBody ::= [Included] "**" Included "with" [Open] ; +MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; + +MReuse. ModBody ::= "reuse" PIdent ; --% +MUnion. ModBody ::= "union" [Included] ;--% + +separator TopDef "" ; + +Ext. Extend ::= [Included] "**" ; +NoExt. Extend ::= ; + +separator Open "," ; +NoOpens. Opens ::= ; +OpenIn. Opens ::= "open" [Open] "in" ; + +OName. Open ::= PIdent ; +-- OQualQO. Open ::= "(" PIdent ")" ; --% +OQual. Open ::= "(" PIdent "=" PIdent ")" ; + +CMCompl. ComplMod ::= ; +CMIncompl. ComplMod ::= "incomplete" ; + +separator Included "," ; + +IAll. Included ::= PIdent ; +ISome. Included ::= PIdent "[" [PIdent] "]" ; +IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; + +-- top-level definitions + +DefCat. TopDef ::= "cat" [CatDef] ; +DefFun. TopDef ::= "fun" [FunDef] ; +DefFunData.TopDef ::= "data" [FunDef] ; +DefDef. TopDef ::= "def" [Def] ; +DefData. TopDef ::= "data" [DataDef] ; + +DefPar. TopDef ::= "param" [ParDef] ; +DefOper. TopDef ::= "oper" [Def] ; + +DefLincat. TopDef ::= "lincat" [Def] ; +DefLindef. TopDef ::= "lindef" [Def] ; +DefLin. TopDef ::= "lin" [Def] ; + +DefPrintCat. TopDef ::= "printname" "cat" [Def] ; +DefPrintFun. TopDef ::= "printname" "fun" [Def] ; +DefFlag. TopDef ::= "flags" [Def] ; + +-- definitions after most keywords + +DDecl. Def ::= [Name] ":" Exp ; +DDef. Def ::= [Name] "=" Exp ; +DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list +DFull. Def ::= [Name] ":" Exp "=" Exp ; + +FDecl. FunDef ::= [Name] ":" Exp ; + +SimpleCatDef. CatDef ::= PIdent [DDecl] ; +ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; +ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; + +DataDef. DataDef ::= Name "=" [DataConstr] ; +DataId. DataConstr ::= PIdent ; +DataQId. DataConstr ::= PIdent "." PIdent ; +separator DataConstr "|" ; + +ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; +ParDefAbs. ParDef ::= PIdent ; + +ParConstr. ParConstr ::= PIdent [DDecl] ; + +terminator nonempty Def ";" ; +terminator nonempty FunDef ";" ; +terminator nonempty CatDef ";" ; +terminator nonempty DataDef ";" ; +terminator nonempty ParDef ";" ; + +separator ParConstr "|" ; + +separator nonempty PIdent "," ; + +-- names of categories and functions in definition LHS + +PIdentName. Name ::= PIdent ; +ListName. Name ::= "[" PIdent "]" ; + +separator nonempty Name "," ; + +-- definitions in records and $let$ expressions + +LDDecl. LocDef ::= [PIdent] ":" Exp ; +LDDef. LocDef ::= [PIdent] "=" Exp ; +LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ; + +separator LocDef ";" ; + +-- terms and types + +EPIdent. Exp6 ::= PIdent ; +EConstr. Exp6 ::= "{" PIdent "}" ;--% +ECons. Exp6 ::= "%" PIdent "%" ;--% +ESort. Exp6 ::= Sort ; +EString. Exp6 ::= String ; +EInt. Exp6 ::= Integer ; +EFloat. Exp6 ::= Double ; +EMeta. Exp6 ::= "?" ; +EEmpty. Exp6 ::= "[" "]" ; +EData. Exp6 ::= "data" ; +EList. Exp6 ::= "[" PIdent Exps "]" ; +EStrings. Exp6 ::= "[" String "]" ; +ERecord. Exp6 ::= "{" [LocDef] "}" ; -- ! +ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator "," +EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --% +ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations + +EProj. Exp5 ::= Exp5 "." Label ; +EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --% +EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --% + +EApp. Exp4 ::= Exp4 Exp5 ; +ETable. Exp4 ::= "table" "{" [Case] "}" ; +ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ; +EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ; +ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ; +EVariants. Exp4 ::= "variants" "{" [Exp] "}" ; +EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; +EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; --% + +EPatt. Exp4 ::= "pattern" Patt2 ; +EPattType. Exp4 ::= "pattern" "type" Exp5 ; + +ESelect. Exp3 ::= Exp3 "!" Exp4 ; +ETupTyp. Exp3 ::= Exp3 "*" Exp4 ; +EExtend. Exp3 ::= Exp3 "**" Exp4 ; + +EGlue. Exp1 ::= Exp2 "+" Exp1 ; + +EConcat. Exp ::= Exp1 "++" Exp ; + +EAbstr. Exp ::= "\\" [Bind] "->" Exp ; +ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; +EProd. Exp ::= Decl "->" Exp ; +ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative +ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; +ELetb. Exp ::= "let" [LocDef] "in" Exp ; +EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ; +EEqs. Exp ::= "fn" "{" [Equation] "}" ; --% + +EExample. Exp ::= "in" Exp5 String ; + +coercions Exp 6 ; + +separator Exp ";" ; -- in variants + +-- list of arguments to category +NilExp. Exps ::= ; +ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses + +-- patterns + +PChar. Patt2 ::= "?" ; +PChars. Patt2 ::= "[" String "]" ; +PMacro. Patt2 ::= "#" PIdent ; +PM. Patt2 ::= "#" PIdent "." PIdent ; +PW. Patt2 ::= "_" ; +PV. Patt2 ::= PIdent ; +PCon. Patt2 ::= "{" PIdent "}" ; --% +PQ. Patt2 ::= PIdent "." PIdent ; +PInt. Patt2 ::= Integer ; +PFloat. Patt2 ::= Double ; +PStr. Patt2 ::= String ; +PR. Patt2 ::= "{" [PattAss] "}" ; +PTup. Patt2 ::= "<" [PattTupleComp] ">" ; +PC. Patt1 ::= PIdent [Patt] ; +PQC. Patt1 ::= PIdent "." PIdent [Patt] ; +PDisj. Patt ::= Patt "|" Patt1 ; +PSeq. Patt ::= Patt "+" Patt1 ; +PRep. Patt1 ::= Patt2 "*" ; +PAs. Patt1 ::= PIdent "@" Patt2 ; +PNeg. Patt1 ::= "-" Patt2 ; + +coercions Patt 2 ; + +PA. PattAss ::= [PIdent] "=" Patt ; + +-- labels + +LPIdent. Label ::= PIdent ; +LVar. Label ::= "$" Integer ; + +-- basic types + +rules Sort ::= + "Type" + | "PType" + | "Tok" --% + | "Str" + | "Strs" ; + +separator PattAss ";" ; + +-- this is explicit to force higher precedence level on rhs +(:[]). [Patt] ::= Patt2 ; +(:). [Patt] ::= Patt2 [Patt] ; + + +-- binds in lambdas and lin rules + +BPIdent. Bind ::= PIdent ; +BWild. Bind ::= "_" ; + +separator Bind "," ; + + +-- declarations in function types + +DDec. Decl ::= "(" [Bind] ":" Exp ")" ; +DExp. Decl ::= Exp4 ; -- can thus be an application + +-- tuple component (term or pattern) + +TComp. TupleComp ::= Exp ; +PTComp. PattTupleComp ::= Patt ; + +separator TupleComp "," ; +separator PattTupleComp "," ; + +-- case branches + +Case. Case ::= Patt "=>" Exp ; + +separator nonempty Case ";" ; + +-- cases in abstract syntax --% + +Equ. Equation ::= [Patt] "->" Exp ; --% + +separator Equation ";" ; --% + +-- prefix alternatives + +Alt. Altern ::= Exp "/" Exp ; + +separator Altern ";" ; + +-- in a context, higher precedence is required than in function types + +DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ; +DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application + +separator DDecl "" ; + + +-------------------------------------- --% + +-- for backward compatibility --% + +OldGr. OldGrammar ::= Include [TopDef] ; --% + +NoIncl. Include ::= ; --% +Incl. Include ::= "include" [FileName] ; --% + +FString. FileName ::= String ; --% + +terminator nonempty FileName ";" ; --% + +FPIdent. FileName ::= PIdent ; --% +FSlash. FileName ::= "/" FileName ; --% +FDot. FileName ::= "." FileName ; --% +FMinus. FileName ::= "-" FileName ; --% +FAddId. FileName ::= PIdent FileName ; --% + +token LString '\'' (char - '\'')* '\'' ; --% +ELString. Exp6 ::= LString ; --% +ELin. Exp4 ::= "Lin" PIdent ; --% + +DefPrintOld. TopDef ::= "printname" [Def] ; --% +DefLintype. TopDef ::= "lintype" [Def] ; --% +DefPattern. TopDef ::= "pattern" [Def] ; --% + +-- deprecated packages are attempted to be interpreted --% +DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --% + +-- these two are just ignored after parsing --% +DefVars. TopDef ::= "var" [Def] ; --% +DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --% diff --git a/src-3.0/GF/Devel/Compile/GFC.hs b/src-3.0/GF/Devel/Compile/GFC.hs new file mode 100644 index 000000000..f60ec9380 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/GFC.hs @@ -0,0 +1,72 @@ +module GF.Devel.Compile.GFC (mainGFC) where +-- module Main where + +import GF.Devel.Compile.Compile +import GF.Devel.Compile.GFtoGFCC +import GF.Devel.PrintGFCC +import GF.GFCC.OptimizeGFCC +import GF.GFCC.CheckGFCC +import GF.GFCC.DataGFCC +import GF.GFCC.Raw.ParGFCCRaw +import GF.GFCC.Raw.ConvertGFCC +import GF.Devel.UseIO +import GF.Infra.Option +import GF.GFCC.API +import GF.Data.ErrM + +mainGFC :: [String] -> IO () +mainGFC xx = do + let (opts,fs) = getOptions "-" xx + case opts of + _ | oElem (iOpt "help") opts -> putStrLn usageMsg + _ | oElem (iOpt "-make") opts -> do + gr <- batchCompile opts fs + let name = justModuleName (last fs) + let (abs,gc0) = mkCanon2gfcc opts name gr + gc1 <- checkGFCCio gc0 + let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1 + let target = targetName opts abs + let gfccFile = target ++ ".gfcc" + writeFile gfccFile (printGFCC gc) + putStrLn $ "wrote file " ++ gfccFile + mapM_ (alsoPrint opts target gc) printOptions + + -- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc + _ | all ((==".gfcc") . takeExtensions) fs -> do + gfccs <- mapM file2gfcc fs + let gfcc = foldl1 unionGFCC gfccs + let abs = printCId $ absname gfcc + let target = targetName opts abs + let gfccFile = target ++ ".gfcc" + writeFile gfccFile (printGFCC gfcc) + putStrLn $ "wrote file " ++ gfccFile + mapM_ (alsoPrint opts target gfcc) printOptions + + _ -> do + mapM_ (batchCompile opts) (map return fs) + putStrLn "Done." + +targetName opts abs = case getOptVal opts (aOpt "target") of + Just n -> n + _ -> abs + +---- TODO: nicer and richer print options + +alsoPrint opts abs gr (opt,name) = do + if oElem (iOpt opt) opts + then do + let outfile = name + let output = prGFCC opt gr + writeFile outfile output + putStrLn $ "wrote file " ++ outfile + else return () + +printOptions = [ + ("haskell","GSyntax.hs"), + ("haskell_gadt","GSyntax.hs"), + ("js","grammar.js"), + ("jsref","grammarReference.js") + ] + +usageMsg = + "usage: gfc (-h | --make (-noopt) (-target=PREFIX) (-js | -jsref | -haskell | -haskell_gadt)) (-src) FILES" diff --git a/src-3.0/GF/Devel/Compile/GFtoGFCC.hs b/src-3.0/GF/Devel/Compile/GFtoGFCC.hs new file mode 100644 index 000000000..81f33e11a --- /dev/null +++ b/src-3.0/GF/Devel/Compile/GFtoGFCC.hs @@ -0,0 +1,542 @@ +module GF.Devel.Compile.GFtoGFCC (prGrammar2gfcc,mkCanon2gfcc) where + +import GF.Devel.Compile.Factorize (unshareModule) + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import qualified GF.Devel.Grammar.Lookup as Look + +import qualified GF.Devel.Grammar.Grammar as A ---- +import qualified GF.Devel.Grammar.Grammar as M ---- +import qualified GF.Devel.Grammar.Macros as GM +--import qualified GF.Grammar.Compute as Compute + +import GF.Devel.Grammar.PrGF +--import GF.Devel.ModDeps +import GF.Infra.Ident + +import GF.Devel.PrintGFCC +import qualified GF.GFCC.Macros as CM +import qualified GF.GFCC.DataGFCC as C +import qualified GF.GFCC.DataGFCC as D +import GF.GFCC.CId +import GF.Infra.Option ---- +import GF.Data.Operations +import GF.Text.UTF8 + +import Data.List +import Data.Char (isDigit,isSpace) +import qualified Data.Map as Map +import Debug.Trace ---- + +-- the main function: generate GFCC from GF. + +prGrammar2gfcc :: Options -> String -> GF -> (String,String) +prGrammar2gfcc opts cnc gr = (abs, printGFCC gc) where + (abs,gc) = mkCanon2gfcc opts cnc gr + +mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC) +mkCanon2gfcc opts cnc gr = + (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr) + where + abs = err error id $ Look.abstractOfConcrete gr (identC cnc) + pars = mkParamLincat gr + +-- Generate GFCC from GFCM. +-- this assumes a grammar translated by canon2canon + +canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> GF -> D.GFCC +canon2gfcc opts pars cgr = + (if (oElem (iOpt "show_canon") opts) then trace (prt cgr) else id) $ + D.GFCC an cns gflags abs cncs + where + -- recognize abstract and concretes + ([(a,abm)],cms) = + partition ((== MTAbstract) . mtype . snd) (Map.toList (gfmodules cgr)) + + -- abstract + an = (i2i a) + cns = map (i2i . fst) cms + abs = D.Abstr aflags funs cats catfuns + gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] + where fg = "firstlang" + aflags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)] + mkDef pty = case pty of + Meta _ -> CM.primNotion + t -> mkExp t + + funs = Map.fromAscList lfuns + cats = Map.fromAscList lcats + + lfuns = [(i2i f, (mkType (jtype ju), mkDef (jdef ju))) | + (f,ju) <- listJudgements abm, jform ju == JFun] + lcats = [(i2i c, mkContext (GM.contextOfType (jtype ju))) | + (c,ju) <- listJudgements abm, jform ju == JCat] + catfuns = Map.fromList + [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] + + -- concretes + cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] + mkConcr lang0 lang mo = + (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) + where + js = listJudgements mo + flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)] + opers = Map.fromAscList [] -- opers will be created as optimization + utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ---- + then D.convertStringsInTerm decodeUTF8 else id + lins = Map.fromAscList + [(i2i f, utf (mkTerm (jdef ju))) | (f,ju) <- js, jform ju == JLin] + lincats = Map.fromAscList + [(i2i c, utf (mkTerm (jtype ju))) | (c,ju) <- js, jform ju == JLincat] + lindefs = Map.fromAscList + [(i2i c, utf (mkTerm (jdef ju))) | (c,ju) <- js, jform ju == JLincat] + printnames = Map.fromAscList + [(i2i c, utf (mkTerm (jprintname ju))) | + (c,ju) <- js, elem (jform ju) [JLincat,JLin]] + params = Map.fromAscList + [(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ?? + fcfg = Nothing + +i2i :: Ident -> CId +i2i = CId . prIdent + +mkType :: A.Type -> C.Type +mkType t = case GM.typeForm t of + (hyps,(Q _ cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args) + +mkExp :: A.Term -> C.Exp +mkExp t = case t of + A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs] + _ -> case GM.termForm t of + (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args) + where + mkAt c = case c of + Q _ c -> C.AC $ i2i c + QC _ c -> C.AC $ i2i c + Vr x -> C.AV $ i2i x + EInt i -> C.AI i + EFloat f -> C.AF f + K s -> C.AS s + Meta i -> C.AM $ toInteger i + _ -> C.AM 0 + mkPatt p = uncurry CM.tree $ case p of + A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps) + A.PV x -> (C.AV (i2i x), []) + A.PW -> (C.AV CM.wildCId, []) + A.PInt i -> (C.AI i, []) + +mkContext :: A.Context -> [C.Hypo] +mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps] + +mkTerm :: Term -> C.Term +mkTerm tr = case tr of + Vr (IA (_,i)) -> C.V i + Vr (IC s) | isDigit (last s) -> + C.V (read (reverse (takeWhile (/='_') (reverse s)))) + ---- from gf parser of gfc + EInt i -> C.C $ fromInteger i + R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] + P t l -> C.P (mkTerm t) (C.C (mkLab l)) + T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ + V _ cs -> C.R [mkTerm t | t <- cs] + S t p -> C.P (mkTerm t) (mkTerm p) + C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] + FV ts -> C.FV [mkTerm t | t <- ts] + K s -> C.K (C.KS s) +----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants + Empty -> C.S [] + App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging + Abs _ t -> mkTerm t ---- only on toplevel + Alts (td,tvs) -> + C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs]) + _ -> prtTrace tr $ C.S [C.K (C.KS (prt tr +++ "66662"))] ---- for debugging + where + mkLab (LIdent l) = case l of + '_':ds -> (read ds) :: Int + _ -> prtTrace tr $ 66663 + strings t = case t of + K s -> [s] + C u v -> strings u ++ strings v + FV ss -> concatMap strings ss + _ -> prtTrace tr $ ["66660"] + flats t = case t of + C.S ts -> concatMap flats ts + _ -> [t] + +-- encoding GFCC-internal lincats as terms +mkCType :: Type -> C.Term +mkCType t = case t of + EInt i -> C.C $ fromInteger i + RecType rs -> C.R [mkCType t | (_, t) <- rs] + Table pt vt -> case pt of + EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt + RecType rs -> mkCType $ foldr Table vt (map snd rs) + Sort "Str" -> C.S [] --- Str only + App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i + _ -> error $ "mkCType " ++ show t + +-- encoding showable lincats (as in source gf) as terms +mkParamLincat :: GF -> Ident -> Ident -> C.Term +mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do + typ <- Look.lookupLincat sgr lang cat + mkPType typ + where + mkPType typ = case typ of + RecType lts -> do + ts <- mapM (mkPType . snd) lts + return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts] + Table (RecType lts) v -> do + ps <- mapM (mkPType . snd) lts + v' <- mkPType v + return $ foldr (\p v -> C.S [p,v]) v' ps + Table p v -> do + p' <- mkPType p + v' <- mkPType v + return $ C.S [p',v'] + Sort "Str" -> return $ C.S [] + _ -> return $ + C.FV $ map (kks . filter showable . prt_) $ + errVal [] $ Look.allParamValues sgr typ + showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records + kks = C.K . C.KS + +-- return just one module per language + +reorder :: Ident -> GF -> GF +reorder abs cg = emptyGF { + gfabsname = Just abs, + gfcncnames = (map fst cncs), + gfmodules = Map.fromList ((abs,absm) : map mkCnc cncs) + } + where + absm = emptyModule { + mtype = MTAbstract, + mflags = aflags, + mjments = adefs + } + mkCnc (c,cnc) = (c,emptyModule { + mtype = MTConcrete abs, + mflags = fst cnc, + mjments = snd cnc + }) + + mos = Map.toList $ gfmodules cg + + adefs = Map.fromAscList $ sortIds $ + predefADefs ++ Look.allOrigJudgements cg abs + predefADefs = + [(IC c, absCat []) | c <- ["Float","Int","String"]] + aflags = Map.fromList $ nubByFst $ concat + [Map.toList (M.mflags mo) | (_,mo) <- mos, mtype mo == MTAbstract] ----toom + + cncs = sortIds [(lang, concr lang) | lang <- Look.allConcretes cg abs] + concr la = ( + Map.fromList (nubByFst flags), + Map.fromList (sortIds (predefCDefs ++ jments)) + ) where + jments = Look.allOrigJudgements cg la + flags = Look.lookupFlags cg la + ----concat [M.mflags mo | + ---- (i,mo) <- mos, M.isModCnc mo, + ---- Just r <- [lookup i (M.allExtendSpecs cg la)]] + + predefCDefs = [(IC c, cncCat GM.defLinType) | + ---- lindef,printname + c <- ["Float","Int","String"]] + + sortIds = sortBy (\ (f,_) (g,_) -> compare f g) + +nubByFst = nubBy (\ (f,_) (g,_) -> f == g) + + +-- one grammar per language - needed for symtab generation +repartition :: Ident -> GF -> [GF] +repartition abs cg = [Look.partOfGrammar cg (lang,mo) | + let mos = gfmodules cg, + lang <- Look.allConcretes cg abs, + let mo = errVal + (error ("no module found for " ++ prt lang)) $ Look.lookupModule cg lang + ] + + +-- translate tables and records to arrays, parameters and labels to indices + +canon2canon :: Ident -> GF -> GF +canon2canon abs gf = errVal gf $ GM.termOpGF t2t gf where + t2t = return . term2term gf pv + ty2ty = type2type gf pv + pv@(labels,untyps,typs) = paramValues gf + ---- should be done lang for lang + ---- ty2ty should be used for types, t2t only in concrete + +{- ---- + gfModules . nubModules . map cl2cl . repartition abs . purgeGrammar abs + where + nubModules = Map.fromList . nubByFst . concatMap (Map.toList . gfmodules) + + cl2cl gf = errVal gf $ GM.moduleOpGF (js2js . map (GM.judgementOpModule p2p)) gf + + js2js ms = map (GM.judgementOpModule (j2j (gfModules ms))) ms + + j2j cg (f,j) = case jform j of + JLin -> (f, j{jdef = t2t (jdef j)}) + JLincat -> (f, j{jdef = t2t (jdef j), jtype = ty2ty (jtype j)}) + _ -> (f,j) + where + t2t = term2term cg pv + ty2ty = type2type cg pv + pv@(labels,untyps,typs) = paramValues cg ---trs $ paramValues cg + + -- flatten record arguments of param constructors + p2p (f,j) = case jform j of + ---- JParam -> + ----ResParam (Yes (ps,v)) -> + ----(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing))) + _ -> (f,j) + unRec (x,ty) = case ty of + RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] + _ -> [(x,ty)] + +---- + trs v = trace (tr v) v + + tr (labels,untyps,typs) = + ("labels:" ++++ + unlines [prt c ++ "." ++ unwords (map prt l) +++ "=" +++ show i | + ((c,l),i) <- Map.toList labels]) ++ + ("untyps:" ++++ unlines [prt t +++ "=" +++ show i | + (t,i) <- Map.toList untyps]) ++ + ("typs:" ++++ unlines [prt t | + (t,_) <- Map.toList typs]) +---- +-} + +purgeGrammar :: Ident -> GF -> GF +purgeGrammar abstr gr = gr { + gfmodules = treat gr + } + where + treat = + Map.fromList . map unopt . filter complete . purge . Map.toList . gfmodules + purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) + needed = + nub $ concatMap (Look.allDepsModule gr) $ + ---- (requiredCanModules True gr) $ + [mo | m <- abstr : Look.allConcretes gr abstr, + Ok mo <- [Look.lookupModule gr m]] + + complete (i,mo) = isCompleteModule mo + unopt = unshareModule gr -- subexp elim undone when compiled + +type ParamEnv = + (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels + Map.Map Term Integer, -- untyped terms to values + Map.Map Type (Map.Map Term Integer)) -- types to their terms to values + +--- gathers those param types that are actually used in lincats and lin terms +paramValues :: GF -> ParamEnv +paramValues cgr = (labels,untyps,typs) where + + jments = [(m,j) | + (m,mo) <- Map.toList (gfmodules cgr), + j <- Map.toList (mjments mo)] + + partyps = nub $ [ty | + (_,(_,ju)) <- jments, + jform ju == JLincat, + RecType ls <- [jtype ju], + ty0 <- [ty | (_, ty) <- unlockTyp ls], + ty <- typsFrom ty0 + ] ++ [Q m ty | + (m,(ty,ju)) <- jments, + jform ju == JParam + ] ++ [ty | + (_,(_,ju)) <- jments, + jform ju == JLin, + ty <- err (const []) snd $ appSTM (typsFromTrm (jdef ju)) [] + ] + params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps] + typsFrom ty = case ty of + Table p t -> typsFrom p ++ typsFrom t + RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls] + _ -> [ty] + + typsFromTrm :: Term -> STM [Type] Term + typsFromTrm tr = case tr of + R fs -> mapM_ (typsFromField . snd) fs >> return tr + where + typsFromField (mty, t) = case mty of + Just x -> updateSTM (x:) >> typsFromTrm t + _ -> typsFromTrm t + V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr + T (TTyped ty) cs -> + updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr + T (TComp ty) cs -> + updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr + _ -> GM.composOp typsFromTrm tr + + typs = + Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] + untyps = + Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] + lincats = + [(IC cat,[(LIdent "s",typeStr)]) | cat <- ["Int", "Float", "String"]] ++ + reverse ---- TODO: really those lincats that are reached + ---- reverse is enough to expel overshadowed ones... + [(cat,(unlockTyp ls)) | + (_,(cat,ju)) <- jments, + jform ju == JLincat, + RecType ls <- [jtype ju] + ] + labels = Map.fromList $ concat + [((cat,[lab]),(typ,i)): + [((cat,[lab,lab2]),(ty,j)) | + rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] + | + (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]] + -- go to tables recursively + ---- TODO: even go to deeper records + where + getRec typ = case typ of + RecType rs -> [rs] + Table _ t -> getRec t + _ -> [] + +type2type :: GF -> ParamEnv -> Type -> Type +type2type cgr env@(labels,untyps,typs) ty = case ty of + RecType rs -> + RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] + Table pt vt -> Table (t2t pt) (t2t vt) + QC _ _ -> look ty + _ -> ty + where + t2t = type2type cgr env + look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of + Just vs -> length $ Map.assocs vs + _ -> trace ("unknown partype " ++ show ty) 66669 + +term2term :: GF -> ParamEnv -> Term -> Term +term2term cgr env@(labels,untyps,typs) tr = case tr of + App _ _ -> mkValCase (unrec tr) + QC _ _ -> mkValCase tr + R rs -> R [(mkLab i, (Nothing, t2t t)) | + (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))] + P t l -> r2r tr + PI t l i -> EInt $ toInteger i + T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc + T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc + V ty ts -> mkCurry $ V ty [t2t t | t <- ts] + S t p -> mkCurrySel (t2t t) (t2t p) + _ -> GM.composSafeOp t2t tr + where + t2t = term2term cgr env + + unrec t = case t of + App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] + _ -> GM.composSafeOp unrec t + + mkValCase tr = case appSTM (doVar tr) [] of + Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st + _ -> valNum $ comp tr + + --- this is mainly needed for parameter record projections + ---- was: errVal t $ Compute.computeConcreteRec cgr t + comp t = case t of + T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should... + T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should + V typ ts -> V typ (map comp ts) + S (V typ ts) v0 -> err error id $ do + let v = comp v0 + return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps + R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r] + P (R r) l -> maybe t (comp . snd) $ lookup l r + _ -> GM.composSafeOp comp t + + doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term + doVar tr = case getLab tr of + Ok (cat, lab) -> do + k <- readSTM >>= return . length + let tr' = Vr $ identC $ show k ----- + + let tyvs = case Map.lookup (cat,lab) labels of + Just (ty,_) -> case Map.lookup ty typs of + Just vs -> (ty,[t | + (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) + (Map.assocs vs)]) + _ -> error $ prt ty + _ -> error $ prt tr + updateSTM ((tyvs, (tr', tr)):) + return tr' + _ -> GM.composOp doVar tr + + r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v + + r2r tr@(P p _) = case getLab tr of + Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ + Map.lookup (cat,labs) labels + _ -> K ((prt tr +++ prtTrace tr "66665")) + + -- this goes recursively into tables (ignored) and records (accumulated) + getLab tr = case tr of + Vr (IA (cat, _)) -> return (identC cat,[]) + Vr (IC s) -> return (identC cat,[]) where + cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser +---- Vr _ -> error $ "getLab " ++ show tr + P p lab2 -> do + (cat,labs) <- getLab p + return (cat,labs++[lab2]) + S p _ -> getLab p + _ -> Bad "getLab" + + + mkCase ((ty,vs),(x,p)) tr = + S (V ty [mkBranch x v tr | v <- vs]) p + mkBranch x t tr = case tr of + _ | tr == x -> t + _ -> GM.composSafeOp (mkBranch x t) tr + + valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps + where + tryFV tr = case GM.appForm tr of + (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] + (FV ts,_) -> ts + _ -> [tr] + valNumFV ts = case ts of + [tr] -> trace (unwords (map prt (Map.keys typs))) $ + prtTrace tr $ K "66667" + _ -> FV $ map valNum ts + + mkCurry trm = case trm of + V (RecType [(_,ty)]) ts -> V ty ts + V (RecType ((_,ty):ltys)) ts -> + V ty [mkCurry (V (RecType ltys) cs) | + cs <- chop (product (map (lengthtyp . snd) ltys)) ts] + _ -> trm + lengthtyp ty = case Map.lookup ty typs of + Just m -> length (Map.assocs m) + _ -> error $ "length of type " ++ show ty + chop i xs = case splitAt i xs of + (xs1,[]) -> [xs1] + (xs1,xs2) -> xs1:chop i xs2 + + + mkCurrySel t p = S t p -- done properly in CheckGFCC + + +mkLab k = LIdent (("_" ++ show k)) + +-- remove lock fields; in fact, any empty records and record types +unlock = filter notlock where + notlock (l,(_, t)) = case t of --- need not look at l + R [] -> False + _ -> True +unlockTyp = filter notlock where + notlock (l, t) = case t of --- need not look at l + RecType [] -> False + _ -> True + +prtTrace tr n = + trace ("-- INTERNAL COMPILER ERROR" +++ prt tr ++++ show n) n +prTrace tr n = trace ("-- OBSERVE" +++ prt tr +++ show n +++ show tr) n + diff --git a/src-3.0/GF/Devel/Compile/GetGrammar.hs b/src-3.0/GF/Devel/Compile/GetGrammar.hs new file mode 100644 index 000000000..b90bd912c --- /dev/null +++ b/src-3.0/GF/Devel/Compile/GetGrammar.hs @@ -0,0 +1,56 @@ +---------------------------------------------------------------------- +-- | +-- Module : GetGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/15 17:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.16 $ +-- +-- this module builds the internal GF grammar that is sent to the type checker +----------------------------------------------------------------------------- + +module GF.Devel.Compile.GetGrammar where + +import GF.Devel.UseIO +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +----import GF.Devel.PrGrammar +import GF.Devel.Compile.SourceToGF +---- import Macros +---- import Rename +--- import Custom +import GF.Devel.Compile.ParGF +import qualified GF.Devel.Compile.LexGF as L + +import GF.Data.Operations +import qualified GF.Devel.Compile.ErrM as E ---- +import GF.Infra.Option ---- +import GF.Devel.ReadFiles ---- + +import Data.Char (toUpper) +import Data.List (nub) +import Control.Monad (foldM) +import System (system) + +getSourceModule :: Options -> FilePath -> IOE SourceModule +getSourceModule opts file0 = do + file <- case getOptVal opts usePreprocessor of + Just p -> do + let tmp = "_gf_preproc.tmp" + cmd = p +++ file0 ++ ">" ++ tmp + ioeIO $ system cmd + -- ioeIO $ putStrLn $ "preproc" +++ cmd + return tmp + _ -> return file0 + string <- readFileIOE file + let tokens = myLexer string + mo1 <- ioeErr $ err2err $ pModDef tokens + ioeErr $ transModDef mo1 + +err2err e = case e of + E.Ok v -> Ok v + E.Bad s -> Bad s + diff --git a/src-3.0/GF/Devel/Compile/LexGF.hs b/src-3.0/GF/Devel/Compile/LexGF.hs new file mode 100644 index 000000000..ff8386f49 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/LexGF.hs @@ -0,0 +1,343 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 3 "GF/Devel/Compile/LexGF.x" #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module GF.Devel.Compile.LexGF where + + + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#else +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x27\x00\x00\x00\x13\x00\x00\x00\x9c\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\x00\x00\x0c\x03\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xe7\x01\x00\x00\xd5\x00\x00\x00\x35\x00\x00\x00\xe7\x00\x00\x00\xf2\x00\x00\x00\x1d\x01\x00\x00\xc2\x01\x00\x00\xcc\x01\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x1a\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x17\x00\x0e\x00\x0e\x00\x0f\x00\x10\x00\x0e\x00\x05\x00\x0e\x00\x0e\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x04\x00\xff\xff\xff\xff\x02\x00\x02\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\x0e\x00\x0e\x00\x16\x00\x16\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x12\x00\xff\xff\x0d\x00\x20\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x09\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0e\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\x07\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1b\x00\xff\xff\x00\x00\x00\x00\x14\x00\x1b\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x1c\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x1c\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x3e\x00\x2b\x00\x27\x00\x27\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x7d\x00\x7d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xf7\x00\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x13\x00\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x0b\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x18\x00\xff\xff\x1b\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,34) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_7))],[],[],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[],[],[]] +{-# LINE 36 "GF/Devel/Compile/LexGF.x" #-} + +tok f p s = f p s + +share :: String -> String +share = id + +data Tok = + TS !String -- reserved words and symbols + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + | T_PIdent !String + | T_LString !String + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + PT _ (T_PIdent s) -> s + PT _ (T_LString s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "lin" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "let" N N)))) (b "resource" (b "oper" (b "lintype" (b "lindef" (b "lincat" N N) N) (b "open" (b "of" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "type" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N)))) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> [Err pos] + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c + +alex_action_3 = tok (\p s -> PT p (TS $ share s)) +alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) +alex_action_5 = tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) +alex_action_6 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_7 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) +alex_action_8 = tok (\p s -> PT p (TI $ share s)) +alex_action_9 = tok (\p s -> PT p (TD $ share s)) +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 35 "GenericTemplate.hs" #-} + +{-# LINE 45 "GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = check_accs (alex_accept `quickIndex` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/src-3.0/GF/Devel/Compile/Optimize.hs b/src-3.0/GF/Devel/Compile/Optimize.hs new file mode 100644 index 000000000..746b47b90 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/Optimize.hs @@ -0,0 +1,333 @@ +---------------------------------------------------------------------- +-- | +-- Module : Optimize +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/16 13:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.18 $ +-- +-- Top-level partial evaluation for GF source modules. +----------------------------------------------------------------------------- + +module GF.Devel.Compile.Optimize (optimizeModule) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros +--import GF.Devel.Grammar.PrGF +import GF.Devel.Grammar.Compute + +--import GF.Infra.Ident + +import GF.Devel.Grammar.Lookup +--import GF.Grammar.Refresh + +--import GF.Compile.BackOpt +import GF.Devel.Compile.CheckGrammar +--import GF.Compile.Update + + +--import GF.Infra.CheckM +import GF.Infra.Option ---- + +import GF.Data.Operations + +import Control.Monad +import Data.List +import qualified Data.Map as Map + +import Debug.Trace + + +optimizeModule :: Options -> GF -> SourceModule -> Err SourceModule +optimizeModule opts gf0 sm@(m,mo) = case mtype mo of + MTConcrete _ -> opt sm + MTInstance _ -> optr sm + MTGrammar -> optr sm + _ -> return sm + where + gf = gf0 {gfmodules = Map.insert m mo (gfmodules gf0)} + opt (m,mo) = do + mo' <- termOpModule (computeTerm gf) mo + return (m,mo') + + optr (m,mo)= do + let deps = allOperDependencies m $ mjments mo + ids <- topoSortOpers deps + gf' <- foldM evalOp gf ids + mo' <- lookupModule gf' m + return $ (m,mo') + where + evalOp gf i = do + ju <- lookupJudgement gf m i + def' <- computeTerm gf (jdef ju) + updateJudgement m i (ju {jdef = def'}) gf + + + + +{- + +-- conditional trace + +prtIf :: (Print a) => Bool -> a -> a +prtIf b t = if b then trace (" " ++ prt t) t else t + +-- | partial evaluation of concrete syntax. +-- AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005 -- 7/12/2007 + +type EEnv = () --- not used + +-- only do this for resource: concrete is optimized in gfc form + + + + =mse@(ms,eenv) mo@(_,mi) = case mi of + ModMod m0@(Module mt st fs me ops js) | + st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do + (mo1,_) <- evalModule oopts mse mo + let + mo2 = case optim of + "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing + "values" -> shareModule valOpt mo1 -- tables as courses-of-values + "share" -> shareModule shareOpt mo1 -- sharing of branches + "all" -> shareModule allOpt mo1 -- first parametrize then values + "none" -> mo1 -- no optimization + _ -> mo1 -- none; default for src + return (mo2,eenv) + _ -> evalModule oopts mse mo + where + oopts = addOptions opts (iOpts (flagsModule mo)) + optim = maybe "all" id $ getOptVal oopts useOptimizer + +evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> + Err ((Ident,SourceModInfo),EEnv) +evalModule oopts (ms,eenv) mo@(name,mod) = case mod of + + ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of + _ | isModRes m0 && not (oElem oEval oopts) -> do + let deps = allOperDependencies name js + ids <- topoSortOpers deps + MGrammar (mod' : _) <- foldM evalOp gr ids + return $ (mod',eenv) + + MTConcrete a -> do + js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 + return $ ((name, ModMod (Module mt st fs me ops js')),eenv) + + _ -> return $ ((name,mod),eenv) + _ -> return $ ((name,mod),eenv) + where + gr0 = MGrammar $ ms + gr = MGrammar $ (name,mod) : ms + + evalOp g@(MGrammar ((_, ModMod m) : _)) i = do + info <- lookupTree prt i $ jments m + info' <- evalResInfo oopts gr (i,info) + return $ updateRes g name i info' + +-- | only operations need be compiled in a resource, and this is local to each +-- definition since the module is traversed in topological order +evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info +evalResInfo oopts gr (c,info) = case info of + + ResOper pty pde -> eIn "operation" $ do + pde' <- case pde of + Yes de | optres -> liftM yes $ comp de + _ -> return pde + return $ ResOper pty pde' + + _ -> return info + where + comp = if optres then computeConcrete gr else computeConcreteRec gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + optim = maybe "all" id $ getOptVal oopts useOptimizer + optres = case optim of + "noexpand" -> False + _ -> True + + +evalCncInfo :: + Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) +evalCncInfo opts gr cnc abs (c,info) = do + + seq (prtIf (oElem beVerbose opts) c) $ return () + + errIn ("optimizing" +++ prt c) $ case info of + + CncCat ptyp pde ppr -> do + pde' <- case (ptyp,pde) of + (Yes typ, Yes de) -> + liftM yes $ pEval ([(strVar, typeStr)], typ) de + (Yes typ, Nope) -> + liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ) + (May b, Nope) -> + return $ May b + _ -> return pde -- indirection + + ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) + + return (c, CncCat ptyp pde' ppr') + + CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> + eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do + pde' <- case pde of + Yes de | notNewEval -> do + liftM yes $ pEval ty de + + _ -> return pde + ppr' <- liftM yes $ evalPrintname gr c ppr pde' + return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed + + _ -> return (c,info) + where + pEval = partEval opts gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + notNewEval = not (oElem oEval opts) + +-- | the main function for compiling linearizations +partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term +partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do + let vars = map fst context + args = map Vr vars + subst = [(v, Vr v) | v <- vars] + trm1 = mkApp trm args + trm3 <- if globalTable + then etaExpand subst trm1 >>= outCase subst + else etaExpand subst trm1 + return $ mkAbs vars trm3 + + where + + globalTable = oElem showAll opts --- i -all + + comp g t = ---- refreshTerm t >>= + computeTerm gr g t + + etaExpand su t = do + t' <- comp su t + case t' of + R _ | rightType t' -> comp su t' --- return t' wo noexpand... + _ -> recordExpand val t' >>= comp su + -- don't eta expand records of right length (correct by type checking) + rightType t = case (t,val) of + (R rs, RecType ts) -> length rs == length ts + _ -> False + + outCase subst t = do + pts <- getParams context + let (args,ptyps) = unzip $ filter (flip occur t . fst) pts + if null args + then return t + else do + let argtyp = RecType $ tuple2recordType ptyps + let pvars = map (Vr . zIdent . prt) args -- gets eliminated + patt <- term2patt $ R $ tuple2record $ pvars + let t' = replace (zip args pvars) t + t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] + return $ S t1 $ R $ tuple2record args + + --- notice: this assumes that all lin types follow the "old JFP style" + getParams = liftM concat . mapM getParam + getParam (argv,RecType rs) = return + [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] + ---getParam (_,ty) | ty==typeStr = return [] --- in lindef + getParam (av,ty) = + Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) + --- all lin types are rec types + + replace :: [(Term,Term)] -> Term -> Term + replace reps trm = case trm of + -- this is the important case + P _ _ -> maybe trm id $ lookup trm reps + _ -> composSafeOp (replace reps) trm + + occur t trm = case trm of + + -- this is the important case + P _ _ -> t == trm + S x y -> occur t y || occur t x + App f x -> occur t x || occur t f + Abs _ f -> occur t f + R rs -> any (occur t) (map (snd . snd) rs) + T _ cs -> any (occur t) (map snd cs) + C x y -> occur t x || occur t y + Glue x y -> occur t x || occur t y + ExtR x y -> occur t x || occur t y + FV ts -> any (occur t) ts + V _ ts -> any (occur t) ts + Let (_,(_,x)) y -> occur t x || occur t y + _ -> False + + +-- here we must be careful not to reduce +-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} +-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; + +recordExpand :: Type -> Term -> Err Term +recordExpand typ trm = case unComputed typ of + RecType tys -> case trm of + FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] + _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] + _ -> return trm + + +-- | auxiliaries for compiling the resource + +mkLinDefault :: SourceGrammar -> Type -> Err Term +mkLinDefault gr typ = do + case unComputed typ of + RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) + _ -> prtBad "linearization type must be a record type, not" typ + where + mkDefField typ = case unComputed typ of + Table p t -> do + t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort "Str" -> return $ Vr strVar + QC q p -> lookupFirstTag gr q p + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM mkDefField ts + return $ R $ [assign l t | (l,t) <- zip ls ts'] + _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val + _ -> prtBad "linearization type field cannot be" typ + +-- | Form the printname: if given, compute. If not, use the computed +-- lin for functions, cat name for cats (dispatch made in evalCncDef above). +--- We cannot use linearization at this stage, since we do not know the +--- defaults we would need for question marks - and we're not yet in canon. +evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term +evalPrintname gr c ppr lin = + case ppr of + Yes pr -> comp pr + _ -> case lin of + Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm + _ -> return $ K $ prt c ---- + where + comp = computeConcrete gr + + oneBranch t = case t of + Abs _ b -> oneBranch b + R (r:_) -> oneBranch $ snd $ snd r + T _ (c:_) -> oneBranch $ snd c + V _ (c:_) -> oneBranch c + FV (t:_) -> oneBranch t + C x y -> C (oneBranch x) (oneBranch y) + S x _ -> oneBranch x + P x _ -> oneBranch x + Alts (d,_) -> oneBranch d + _ -> t + + --- very unclean cleaner + clean s = case s of + '+':'+':' ':cs -> clean cs + '"':cs -> clean cs + c:cs -> c: clean cs + _ -> s + +-} diff --git a/src-3.0/GF/Devel/Compile/ParGF.hs b/src-3.0/GF/Devel/Compile/ParGF.hs new file mode 100644 index 000000000..ce474e418 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/ParGF.hs @@ -0,0 +1,3210 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +module GF.Devel.Compile.ParGF where +import GF.Devel.Compile.AbsGF +import GF.Devel.Compile.LexGF +import GF.Devel.Compile.ErrM +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.16 + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn7 :: (Integer) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Integer) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (String) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (String) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Double) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Double) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (PIdent) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (PIdent) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (LString) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (LString) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Grammar) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Grammar) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([ModDef]) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([ModDef]) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (ModDef) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (ModDef) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (ModType) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (ModType) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (ModBody) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (ModBody) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([TopDef]) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([TopDef]) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Extend) -> (HappyAbsSyn ) +happyIn18 x = unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (Extend) +happyOut18 x = unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: ([Open]) -> (HappyAbsSyn ) +happyIn19 x = unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> ([Open]) +happyOut19 x = unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (Opens) -> (HappyAbsSyn ) +happyIn20 x = unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (Opens) +happyOut20 x = unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (Open) -> (HappyAbsSyn ) +happyIn21 x = unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> (Open) +happyOut21 x = unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (ComplMod) -> (HappyAbsSyn ) +happyIn22 x = unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (ComplMod) +happyOut22 x = unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: ([Included]) -> (HappyAbsSyn ) +happyIn23 x = unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> ([Included]) +happyOut23 x = unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: (Included) -> (HappyAbsSyn ) +happyIn24 x = unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> (Included) +happyOut24 x = unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: (TopDef) -> (HappyAbsSyn ) +happyIn25 x = unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> (TopDef) +happyOut25 x = unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: (Def) -> (HappyAbsSyn ) +happyIn26 x = unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> (Def) +happyOut26 x = unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: (FunDef) -> (HappyAbsSyn ) +happyIn27 x = unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> (FunDef) +happyOut27 x = unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: (CatDef) -> (HappyAbsSyn ) +happyIn28 x = unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> (CatDef) +happyOut28 x = unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: (DataDef) -> (HappyAbsSyn ) +happyIn29 x = unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> (DataDef) +happyOut29 x = unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: (DataConstr) -> (HappyAbsSyn ) +happyIn30 x = unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> (DataConstr) +happyOut30 x = unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: ([DataConstr]) -> (HappyAbsSyn ) +happyIn31 x = unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> ([DataConstr]) +happyOut31 x = unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: (ParDef) -> (HappyAbsSyn ) +happyIn32 x = unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> (ParDef) +happyOut32 x = unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: (ParConstr) -> (HappyAbsSyn ) +happyIn33 x = unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> (ParConstr) +happyOut33 x = unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: ([Def]) -> (HappyAbsSyn ) +happyIn34 x = unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> ([Def]) +happyOut34 x = unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: ([FunDef]) -> (HappyAbsSyn ) +happyIn35 x = unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> ([FunDef]) +happyOut35 x = unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: ([CatDef]) -> (HappyAbsSyn ) +happyIn36 x = unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> ([CatDef]) +happyOut36 x = unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: ([DataDef]) -> (HappyAbsSyn ) +happyIn37 x = unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> ([DataDef]) +happyOut37 x = unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: ([ParDef]) -> (HappyAbsSyn ) +happyIn38 x = unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> ([ParDef]) +happyOut38 x = unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: ([ParConstr]) -> (HappyAbsSyn ) +happyIn39 x = unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> ([ParConstr]) +happyOut39 x = unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: ([PIdent]) -> (HappyAbsSyn ) +happyIn40 x = unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> ([PIdent]) +happyOut40 x = unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: (Name) -> (HappyAbsSyn ) +happyIn41 x = unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> (Name) +happyOut41 x = unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: ([Name]) -> (HappyAbsSyn ) +happyIn42 x = unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> ([Name]) +happyOut42 x = unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: (LocDef) -> (HappyAbsSyn ) +happyIn43 x = unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> (LocDef) +happyOut43 x = unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: ([LocDef]) -> (HappyAbsSyn ) +happyIn44 x = unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> ([LocDef]) +happyOut44 x = unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: (Exp) -> (HappyAbsSyn ) +happyIn45 x = unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> (Exp) +happyOut45 x = unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: (Exp) -> (HappyAbsSyn ) +happyIn46 x = unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> (Exp) +happyOut46 x = unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: (Exp) -> (HappyAbsSyn ) +happyIn47 x = unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> (Exp) +happyOut47 x = unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: (Exp) -> (HappyAbsSyn ) +happyIn48 x = unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> (Exp) +happyOut48 x = unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: (Exp) -> (HappyAbsSyn ) +happyIn49 x = unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> (Exp) +happyOut49 x = unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: (Exp) -> (HappyAbsSyn ) +happyIn50 x = unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> (Exp) +happyOut50 x = unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: (Exp) -> (HappyAbsSyn ) +happyIn51 x = unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> (Exp) +happyOut51 x = unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: ([Exp]) -> (HappyAbsSyn ) +happyIn52 x = unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> ([Exp]) +happyOut52 x = unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: (Exps) -> (HappyAbsSyn ) +happyIn53 x = unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> (Exps) +happyOut53 x = unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: (Patt) -> (HappyAbsSyn ) +happyIn54 x = unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> (Patt) +happyOut54 x = unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyIn55 :: (Patt) -> (HappyAbsSyn ) +happyIn55 x = unsafeCoerce# x +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> (Patt) +happyOut55 x = unsafeCoerce# x +{-# INLINE happyOut55 #-} +happyIn56 :: (Patt) -> (HappyAbsSyn ) +happyIn56 x = unsafeCoerce# x +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> (Patt) +happyOut56 x = unsafeCoerce# x +{-# INLINE happyOut56 #-} +happyIn57 :: (PattAss) -> (HappyAbsSyn ) +happyIn57 x = unsafeCoerce# x +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> (PattAss) +happyOut57 x = unsafeCoerce# x +{-# INLINE happyOut57 #-} +happyIn58 :: (Label) -> (HappyAbsSyn ) +happyIn58 x = unsafeCoerce# x +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> (Label) +happyOut58 x = unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyIn59 :: (Sort) -> (HappyAbsSyn ) +happyIn59 x = unsafeCoerce# x +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> (Sort) +happyOut59 x = unsafeCoerce# x +{-# INLINE happyOut59 #-} +happyIn60 :: ([PattAss]) -> (HappyAbsSyn ) +happyIn60 x = unsafeCoerce# x +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn ) -> ([PattAss]) +happyOut60 x = unsafeCoerce# x +{-# INLINE happyOut60 #-} +happyIn61 :: ([Patt]) -> (HappyAbsSyn ) +happyIn61 x = unsafeCoerce# x +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn ) -> ([Patt]) +happyOut61 x = unsafeCoerce# x +{-# INLINE happyOut61 #-} +happyIn62 :: (Bind) -> (HappyAbsSyn ) +happyIn62 x = unsafeCoerce# x +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn ) -> (Bind) +happyOut62 x = unsafeCoerce# x +{-# INLINE happyOut62 #-} +happyIn63 :: ([Bind]) -> (HappyAbsSyn ) +happyIn63 x = unsafeCoerce# x +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn ) -> ([Bind]) +happyOut63 x = unsafeCoerce# x +{-# INLINE happyOut63 #-} +happyIn64 :: (Decl) -> (HappyAbsSyn ) +happyIn64 x = unsafeCoerce# x +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn ) -> (Decl) +happyOut64 x = unsafeCoerce# x +{-# INLINE happyOut64 #-} +happyIn65 :: (TupleComp) -> (HappyAbsSyn ) +happyIn65 x = unsafeCoerce# x +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn ) -> (TupleComp) +happyOut65 x = unsafeCoerce# x +{-# INLINE happyOut65 #-} +happyIn66 :: (PattTupleComp) -> (HappyAbsSyn ) +happyIn66 x = unsafeCoerce# x +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn ) -> (PattTupleComp) +happyOut66 x = unsafeCoerce# x +{-# INLINE happyOut66 #-} +happyIn67 :: ([TupleComp]) -> (HappyAbsSyn ) +happyIn67 x = unsafeCoerce# x +{-# INLINE happyIn67 #-} +happyOut67 :: (HappyAbsSyn ) -> ([TupleComp]) +happyOut67 x = unsafeCoerce# x +{-# INLINE happyOut67 #-} +happyIn68 :: ([PattTupleComp]) -> (HappyAbsSyn ) +happyIn68 x = unsafeCoerce# x +{-# INLINE happyIn68 #-} +happyOut68 :: (HappyAbsSyn ) -> ([PattTupleComp]) +happyOut68 x = unsafeCoerce# x +{-# INLINE happyOut68 #-} +happyIn69 :: (Case) -> (HappyAbsSyn ) +happyIn69 x = unsafeCoerce# x +{-# INLINE happyIn69 #-} +happyOut69 :: (HappyAbsSyn ) -> (Case) +happyOut69 x = unsafeCoerce# x +{-# INLINE happyOut69 #-} +happyIn70 :: ([Case]) -> (HappyAbsSyn ) +happyIn70 x = unsafeCoerce# x +{-# INLINE happyIn70 #-} +happyOut70 :: (HappyAbsSyn ) -> ([Case]) +happyOut70 x = unsafeCoerce# x +{-# INLINE happyOut70 #-} +happyIn71 :: (Equation) -> (HappyAbsSyn ) +happyIn71 x = unsafeCoerce# x +{-# INLINE happyIn71 #-} +happyOut71 :: (HappyAbsSyn ) -> (Equation) +happyOut71 x = unsafeCoerce# x +{-# INLINE happyOut71 #-} +happyIn72 :: ([Equation]) -> (HappyAbsSyn ) +happyIn72 x = unsafeCoerce# x +{-# INLINE happyIn72 #-} +happyOut72 :: (HappyAbsSyn ) -> ([Equation]) +happyOut72 x = unsafeCoerce# x +{-# INLINE happyOut72 #-} +happyIn73 :: (Altern) -> (HappyAbsSyn ) +happyIn73 x = unsafeCoerce# x +{-# INLINE happyIn73 #-} +happyOut73 :: (HappyAbsSyn ) -> (Altern) +happyOut73 x = unsafeCoerce# x +{-# INLINE happyOut73 #-} +happyIn74 :: ([Altern]) -> (HappyAbsSyn ) +happyIn74 x = unsafeCoerce# x +{-# INLINE happyIn74 #-} +happyOut74 :: (HappyAbsSyn ) -> ([Altern]) +happyOut74 x = unsafeCoerce# x +{-# INLINE happyOut74 #-} +happyIn75 :: (DDecl) -> (HappyAbsSyn ) +happyIn75 x = unsafeCoerce# x +{-# INLINE happyIn75 #-} +happyOut75 :: (HappyAbsSyn ) -> (DDecl) +happyOut75 x = unsafeCoerce# x +{-# INLINE happyOut75 #-} +happyIn76 :: ([DDecl]) -> (HappyAbsSyn ) +happyIn76 x = unsafeCoerce# x +{-# INLINE happyIn76 #-} +happyOut76 :: (HappyAbsSyn ) -> ([DDecl]) +happyOut76 x = unsafeCoerce# x +{-# INLINE happyOut76 #-} +happyIn77 :: (OldGrammar) -> (HappyAbsSyn ) +happyIn77 x = unsafeCoerce# x +{-# INLINE happyIn77 #-} +happyOut77 :: (HappyAbsSyn ) -> (OldGrammar) +happyOut77 x = unsafeCoerce# x +{-# INLINE happyOut77 #-} +happyIn78 :: (Include) -> (HappyAbsSyn ) +happyIn78 x = unsafeCoerce# x +{-# INLINE happyIn78 #-} +happyOut78 :: (HappyAbsSyn ) -> (Include) +happyOut78 x = unsafeCoerce# x +{-# INLINE happyOut78 #-} +happyIn79 :: (FileName) -> (HappyAbsSyn ) +happyIn79 x = unsafeCoerce# x +{-# INLINE happyIn79 #-} +happyOut79 :: (HappyAbsSyn ) -> (FileName) +happyOut79 x = unsafeCoerce# x +{-# INLINE happyOut79 #-} +happyIn80 :: ([FileName]) -> (HappyAbsSyn ) +happyIn80 x = unsafeCoerce# x +{-# INLINE happyIn80 #-} +happyOut80 :: (HappyAbsSyn ) -> ([FileName]) +happyOut80 x = unsafeCoerce# x +{-# INLINE happyOut80 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x00\x00\x34\x04\x2a\x04\xe9\x00\x0d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x04\x90\x01\x6f\x00\x37\x04\xfa\x03\x35\x04\x00\x00\x31\x04\xe7\x03\xfe\xff\x1c\x00\xe7\x03\x00\x00\xe9\x00\x29\x00\xe7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x30\x04\x63\x02\x06\x00\x00\x03\x2f\x04\x2e\x04\x58\x02\x2d\x04\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x03\x00\x00\xf9\xff\x01\x00\x6e\x08\x00\x00\xdc\x03\x4e\x00\x2c\x04\x1c\x04\xc6\x03\xc6\x03\xc6\x03\xc6\x03\xc6\x03\xc6\x03\x00\x00\x00\x00\xf9\xff\x13\x04\x00\x00\xf9\xff\xf9\xff\xf9\xff\xf6\x07\xe9\x00\x17\x01\xeb\x02\x9b\x00\xc4\x03\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x03\x04\x00\x00\xc3\x03\xeb\x02\xc1\x03\x00\x00\xeb\x02\xc0\x03\x00\x00\x0a\x02\x06\x04\x39\x00\x0a\x04\xdb\x03\xb1\x03\x1b\x00\x16\x03\xd4\x03\x00\x00\x00\x00\xf3\x03\xdf\x03\x77\x00\x00\x00\xee\x03\xf0\x03\xe2\x03\x43\x02\xeb\x03\xff\x01\x00\x00\xd6\x00\xea\x03\xe5\x03\xf4\x01\x8d\x02\xe8\x03\x4d\x00\x37\x01\x4d\x00\x37\x01\x37\x01\x37\x01\x4d\x00\xe1\x03\xd6\x03\xef\xff\x00\x00\x00\x00\x96\x03\x8d\x03\x00\x00\xf4\x01\xf4\x01\xf4\x01\x00\x00\xf4\x01\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x03\x8d\x03\xd3\x03\x4d\x00\x00\x00\xa6\x01\xd0\x03\x89\x03\x00\x00\x89\x03\x00\x00\x00\x00\x4d\x00\x4d\x00\xbe\x03\x4d\x00\x77\x00\xd2\x03\x16\x03\xbc\x03\xd1\x03\xcc\x03\x00\x00\xc7\x03\x4d\x00\x84\x03\x4d\x00\x4d\x00\xbd\x03\xa7\x03\xb1\x02\xa3\x03\x00\x00\xf9\x00\xad\x03\x99\x03\x16\x03\xa8\x03\x7a\x02\xe8\x01\xae\x03\xa9\x03\xa0\x03\x54\x03\xa1\x03\x9e\x03\x93\x03\x83\x03\x87\x02\x5f\x01\x8a\x03\x86\x03\xeb\x02\x4d\x00\x81\x03\x00\x00\x2b\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x34\x03\x34\x03\x28\x00\x02\x00\x34\x03\x28\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x00\x00\x00\x00\x4b\x03\x00\x00\x49\x03\x00\x00\x18\x00\x2f\x02\x00\x00\x46\x03\x78\x03\x30\x00\x32\x03\x32\x03\x32\x03\x32\x03\x00\x00\x00\x00\x76\x03\x00\x00\xd6\x02\x33\x00\x25\x03\x72\x03\x00\x00\x28\x00\x28\x00\x00\x00\x6e\x03\x6a\x03\x00\x00\x57\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x03\x00\x00\x64\x03\x4a\x03\x00\x00\x00\x00\x53\x03\x00\x00\x00\x00\x87\x00\x00\x00\x4f\x03\x00\x00\xfc\x02\x00\x00\x40\x03\x44\x03\x00\x00\xc7\x02\xc7\x02\xc7\x02\x4d\x00\x00\x00\xf6\x02\x16\x03\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\xf6\x02\xc7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x02\x00\x00\xf6\x02\x42\x03\x00\x00\x00\x00\x00\x00\x14\x03\x00\x00\x16\x03\x4d\x00\x00\x00\xc7\x02\x00\x00\x00\x00\x4d\x00\x24\x03\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\x00\x00\x38\x03\x00\x00\x30\x03\x00\x00\x2e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x03\x00\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0b\x03\x20\x03\x1a\x03\x00\x00\x00\x00\x16\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x9b\x01\xe4\x02\xfa\xff\xfa\xff\x4d\x00\xfa\xff\x19\x03\xd9\x02\xd9\x02\x00\x00\x00\x00\x00\x00\x0e\x03\x4d\x00\x4d\x00\x10\x03\xfa\xff\x00\x00\x00\x00\x00\x00\x11\x03\x00\x00\xbc\x02\x0a\x00\xbc\x02\x07\x03\x0a\x00\xb9\x02\xfb\x02\xb3\x02\xf7\x02\x00\x00\xcb\x02\xf3\x02\xa9\x02\x00\x00\xaa\x02\xee\x02\x00\x00\x00\x00\x4d\x00\xe3\x02\x00\x00\x00\x00\x00\x00\xda\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x02\x00\x00\xd7\x02\xd2\x02\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x42\x01\x00\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x02\xcf\x02\x82\x02\x82\x02\x91\x03\x82\x02\x9b\x01\x4d\x00\x00\x00\xa0\x02\x0a\x00\x71\x03\xcd\x02\x0a\x00\x00\x00\x00\x00\xbe\x02\x00\x00\x00\x00\x6e\x02\x00\x00\xc4\x02\xb8\x02\x00\x00\x00\x00\xb5\x02\x00\x00\x00\x00\x4d\x00\x69\x02\xa7\x02\xa2\x02\x00\x00\x00\x00\x6f\x02\x97\x02\x00\x00\x9a\x02\x51\x03\x00\x00\x00\x00\x00\x00\x00\x00\x31\x03\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x78\x00\x22\x02\x8b\x01\x9e\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x03\x54\x04\x3c\x01\x96\x02\x00\x00\x17\x04\xca\x00\x93\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x07\x00\x00\x00\x00\xf2\x07\x6f\x03\x3c\x02\x00\x00\x00\x00\xd3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x19\x00\x00\x00\x81\x02\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x6d\x02\x6b\x02\x6a\x02\x5f\x02\x5d\x02\x5b\x02\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x22\x00\x13\x00\x07\x00\x4b\x02\xc8\x04\x00\x00\x4d\x01\x64\x07\x59\x02\xac\x04\x46\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x01\x46\x02\x50\x02\x00\x00\x0c\x03\x47\x02\x00\x00\xe7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x03\x44\x02\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x07\x00\x00\x00\x00\x00\x00\x00\x00\x44\x04\x00\x00\x00\x00\x2a\x07\xc3\x02\x0c\x07\xbc\x07\xad\x07\x2b\x03\xf0\x06\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x1c\x02\x1d\x03\x00\x00\x28\x04\x28\x04\x28\x04\x00\x00\x28\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x08\x02\x00\x00\xd2\x06\x00\x00\xcb\x07\x00\x00\x9b\x02\x00\x00\x07\x02\x00\x00\x00\x00\xfb\x03\xb6\x06\x00\x00\x98\x06\x5d\x00\x00\x00\xcb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x06\x00\x01\x5e\x06\x42\x06\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\xc0\x01\x8e\x04\x00\x00\x00\x00\x91\x01\xf4\x07\x77\x08\x75\x08\x69\x08\x64\x08\x5e\x08\x53\x08\x50\x08\x47\x08\xea\x01\x69\x01\x42\x08\x3d\x08\xdf\x01\x39\x08\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x00\x00\xd4\x01\x00\x00\x00\x00\xd5\x01\x8a\x01\xc2\x01\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\x00\x00\x95\x01\x00\x00\x00\x00\x2c\x08\xa0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x00\x00\x00\x00\x87\x01\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\xed\x03\x7d\x02\x24\x06\x00\x00\x7c\x01\x37\x00\x00\x00\x72\x04\xdd\x03\x00\x00\x00\x00\xd7\x01\x24\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x02\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x08\x06\x00\x00\x84\x00\x00\x00\x00\x00\xea\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x05\xb0\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x6c\x01\xad\x00\x47\x01\xa6\x00\x0d\x01\x94\x05\x26\x08\x00\x00\xb3\x00\x59\x01\x00\x00\x00\x00\x00\x00\x00\x00\x76\x05\x5a\x05\x00\x00\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\xab\x02\x90\x00\x00\x00\x2d\x02\xcd\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x05\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x04\x00\x00\xad\x00\x00\x00\x00\x00\xbf\x03\x20\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\xf4\x00\xdb\x00\xfc\x00\xad\x00\x02\x05\x00\x00\xd3\x00\xcd\x01\xbc\x00\x00\x00\x99\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x04\xcb\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x53\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xf5\xff\xd8\xff\x17\xff\x00\x00\x00\x00\xfb\xff\x8e\xff\x8f\xff\x8d\xff\x93\xff\x82\xff\x7e\xff\x73\xff\x6e\xff\x60\xff\x61\xff\x00\x00\x6c\xff\x90\xff\x00\x00\x96\xff\x34\xff\x00\x00\x00\x00\x8c\xff\x2d\xff\x34\xff\x00\x00\x3f\xff\x3d\xff\x3c\xff\x3e\xff\x40\xff\x00\x00\x8a\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\xf9\xff\xf8\xff\xf7\xff\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\xd8\xff\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\x15\xff\x14\xff\x00\x00\x16\xff\x00\x00\x00\x00\x00\x00\x18\xff\x5f\xff\x00\x00\x96\xff\x00\x00\x00\x00\x5f\xff\x00\x00\x52\xff\x50\xff\x51\xff\x55\xff\x75\xff\x3b\xff\x00\x00\x00\x00\x5a\xff\x2a\xff\x00\x00\x56\xff\x00\x00\x9f\xff\x00\x00\x95\xff\x00\x00\x96\xff\x00\x00\x23\xff\x00\x00\x72\xff\x36\xff\x33\xff\x00\x00\x34\xff\x35\xff\x2f\xff\x2c\xff\x00\x00\x00\x00\x00\x00\x5c\xff\x8b\xff\x93\xff\x00\x00\x00\x00\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xff\x00\x00\x42\xff\x81\xff\x00\x00\x96\xff\x67\xff\x70\xff\x71\xff\x6f\xff\x6b\xff\x6e\xff\x60\xff\x6d\xff\x68\xff\x87\xff\x92\xff\x00\x00\x00\x00\x93\xff\x00\x00\x83\xff\x5c\xff\x00\x00\x96\xff\x88\xff\x00\x00\x91\xff\x86\xff\x2d\xff\x00\x00\x00\x00\x00\x00\x34\xff\x00\x00\x38\xff\x00\x00\x22\xff\x00\x00\x62\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x74\xff\x58\xff\x55\xff\x47\xff\x44\xff\x2e\xff\x29\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9f\xff\x00\x00\x3a\xff\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x00\x00\x9f\xff\x00\x00\x26\xff\x00\x00\x00\x00\x5f\xff\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\xff\x12\xff\x11\xff\x0f\xff\x10\xff\xf0\xff\xee\xff\x00\x00\xef\xff\x00\x00\xf1\xff\xd6\xff\xd3\xff\xf2\xff\xdc\xff\xea\xff\xd5\xff\x00\x00\xd6\xff\x00\x00\x00\x00\x0e\xff\x9d\xff\x00\x00\xbf\xff\x9b\xff\x00\x00\x00\x00\x00\x00\xc3\xff\x00\x00\x00\x00\xc1\xff\xae\xff\x00\x00\xcb\xff\x00\x00\xca\xff\xc2\xff\xc8\xff\xc9\xff\xc7\xff\x00\x00\xcf\xff\x9b\xff\x00\x00\xc4\xff\xcd\xff\x00\x00\xce\xff\xcc\xff\x9b\xff\x1a\xff\x00\x00\xd0\xff\x00\x00\x78\xff\x00\x00\x00\x00\x7c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x4c\xff\x00\x00\x00\x00\x76\xff\x5f\xff\x1f\xff\x53\xff\x4f\xff\x3b\xff\x00\x00\x54\xff\x4d\xff\x59\xff\x48\xff\x4e\xff\x2a\xff\x4a\xff\x00\x00\x99\xff\x98\xff\x94\xff\x65\xff\x00\x00\x63\xff\x23\xff\x00\x00\x37\xff\x00\x00\x32\xff\x6a\xff\x00\x00\x00\x00\x2f\xff\x2b\xff\x7f\xff\x9f\xff\x89\xff\x5b\xff\x00\x00\x85\xff\x00\x00\x9e\xff\x00\x00\x41\xff\x64\xff\x80\xff\x31\xff\x84\xff\x69\xff\x00\x00\x24\xff\x21\xff\x00\x00\x00\x00\x57\xff\x28\xff\x43\xff\x39\xff\x00\x00\x1e\xff\x00\x00\x5d\xff\x49\xff\x53\xff\x27\xff\x45\xff\x46\xff\x25\xff\x7b\xff\x7a\xff\x1a\xff\xa8\xff\xb8\xff\xb2\xff\x00\x00\xa6\xff\x00\x00\xaa\xff\x00\x00\xa4\xff\xa2\xff\xc5\xff\xc6\xff\xbe\xff\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\xec\xff\xed\xff\xe4\xff\xd5\xff\xe5\xff\xd6\xff\xdf\xff\xe1\xff\x00\x00\xdf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\x00\x00\xde\xff\x00\x00\xe3\xff\x00\x00\xe9\xff\xd4\xff\xab\xff\x00\x00\xbd\xff\xbc\xff\x9c\xff\x1a\xff\xa1\xff\xaf\xff\xa3\xff\xe3\xff\xa9\xff\xb9\xff\xa5\xff\x00\x00\x9a\xff\xb4\xff\xb1\xff\xb5\xff\x1b\xff\x19\xff\x34\xff\xa7\xff\x00\x00\x4b\xff\x77\xff\x1f\xff\x00\x00\x97\xff\x66\xff\x79\xff\x20\xff\x1d\xff\xb7\xff\x00\x00\xb2\xff\x00\x00\x00\x00\xa2\xff\xad\xff\x00\x00\xbb\xff\xdc\xff\xdf\xff\x00\x00\x00\x00\xdf\xff\xdb\xff\xd2\xff\x00\x00\xd1\xff\xdd\xff\x00\x00\xeb\xff\xe7\xff\x00\x00\xba\xff\xa0\xff\x00\x00\xb3\xff\xb0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xe3\xff\xdc\xff\x00\x00\xd9\xff\x00\x00\x00\x00\x1c\xff\xb6\xff\xe8\xff\xe3\xff\x00\x00\xe6\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x09\x00\x0b\x00\x07\x00\x0d\x00\x09\x00\x01\x00\x03\x00\x03\x00\x09\x00\x1d\x00\x0f\x00\x10\x00\x11\x00\x01\x00\x07\x00\x03\x00\x03\x00\x01\x00\x17\x00\x03\x00\x1e\x00\x0a\x00\x1b\x00\x01\x00\x03\x00\x03\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x01\x00\x26\x00\x03\x00\x0a\x00\x29\x00\x0d\x00\x27\x00\x2c\x00\x07\x00\x09\x00\x2f\x00\x01\x00\x2d\x00\x03\x00\x09\x00\x34\x00\x0f\x00\x09\x00\x02\x00\x06\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x3e\x00\x3f\x00\x4f\x00\x0c\x00\x17\x00\x43\x00\x44\x00\x33\x00\x1b\x00\x0c\x00\x4d\x00\x49\x00\x4f\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x48\x00\x03\x00\x4f\x00\x3a\x00\x52\x00\x07\x00\x4f\x00\x09\x00\x48\x00\x49\x00\x4f\x00\x42\x00\x48\x00\x0f\x00\x10\x00\x11\x00\x47\x00\x03\x00\x48\x00\x49\x00\x03\x00\x17\x00\x12\x00\x2f\x00\x4f\x00\x4d\x00\x4d\x00\x48\x00\x4f\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x4f\x00\x26\x00\x05\x00\x48\x00\x29\x00\x4f\x00\x4f\x00\x2c\x00\x4f\x00\x4b\x00\x2f\x00\x05\x00\x06\x00\x31\x00\x05\x00\x34\x00\x13\x00\x14\x00\x00\x00\x01\x00\x02\x00\x03\x00\x19\x00\x02\x00\x0d\x00\x3e\x00\x3f\x00\x06\x00\x13\x00\x14\x00\x43\x00\x44\x00\x1b\x00\x03\x00\x37\x00\x38\x00\x49\x00\x37\x00\x38\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x12\x00\x52\x00\x11\x00\x07\x00\x03\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x17\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x17\x00\x18\x00\x4a\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0a\x00\x26\x00\x3e\x00\x3f\x00\x29\x00\x03\x00\x4f\x00\x2c\x00\x22\x00\x23\x00\x2f\x00\x00\x00\x19\x00\x03\x00\x12\x00\x34\x00\x03\x00\x03\x00\x1f\x00\x26\x00\x2f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x3e\x00\x3f\x00\x36\x00\x06\x00\x03\x00\x43\x00\x44\x00\x0d\x00\x34\x00\x0c\x00\x21\x00\x49\x00\x40\x00\x41\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x12\x00\x21\x00\x21\x00\x07\x00\x44\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x17\x00\x37\x00\x38\x00\x03\x00\x2f\x00\x30\x00\x31\x00\x0e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x15\x00\x26\x00\x03\x00\x03\x00\x29\x00\x3e\x00\x3f\x00\x2c\x00\x1a\x00\x09\x00\x2f\x00\x0b\x00\x03\x00\x0a\x00\x20\x00\x34\x00\x10\x00\x11\x00\x09\x00\x21\x00\x2f\x00\x16\x00\x24\x00\x25\x00\x45\x00\x3e\x00\x3f\x00\x36\x00\x2f\x00\x1e\x00\x43\x00\x44\x00\x03\x00\x22\x00\x0a\x00\x36\x00\x49\x00\x40\x00\x41\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x10\x00\x11\x00\x01\x00\x07\x00\x03\x00\x09\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x03\x00\x09\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x03\x00\x45\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x03\x00\x26\x00\x17\x00\x18\x00\x29\x00\x03\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x0e\x00\x21\x00\x03\x00\x2f\x00\x24\x00\x25\x00\x1a\x00\x15\x00\x3e\x00\x3f\x00\x36\x00\x19\x00\x20\x00\x43\x00\x44\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x49\x00\x15\x00\x19\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x1f\x00\x1d\x00\x03\x00\x3e\x00\x3f\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x03\x00\x45\x00\x2f\x00\x07\x00\x03\x00\x09\x00\x10\x00\x11\x00\x03\x00\x36\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x03\x00\x09\x00\x0c\x00\x15\x00\x0e\x00\x18\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x1d\x00\x09\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x10\x00\x11\x00\x04\x00\x29\x00\x06\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x03\x00\x46\x00\x47\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\x0c\x00\x03\x00\x0e\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0d\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x04\x00\x03\x00\x06\x00\x2f\x00\x30\x00\x31\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x21\x00\x26\x00\x2f\x00\x07\x00\x03\x00\x09\x00\x3e\x00\x3f\x00\x03\x00\x36\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x34\x00\x09\x00\x32\x00\x03\x00\x03\x00\x35\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x2f\x00\x09\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x10\x00\x11\x00\x00\x00\x29\x00\x21\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x07\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x32\x00\x03\x00\x0f\x00\x35\x00\x29\x00\x00\x00\x01\x00\x02\x00\x03\x00\x09\x00\x0c\x00\x0b\x00\x0e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x01\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0d\x00\x01\x00\x0f\x00\x2f\x00\x30\x00\x31\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x03\x00\x12\x00\x03\x00\x07\x00\x03\x00\x09\x00\x03\x00\x2f\x00\x30\x00\x31\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x2f\x00\x09\x00\x03\x00\x03\x00\x3b\x00\x03\x00\x3d\x00\x0f\x00\x10\x00\x11\x00\x2f\x00\x30\x00\x31\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x00\x00\x01\x00\x02\x00\x03\x00\x29\x00\x08\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0e\x00\x08\x00\x03\x00\x04\x00\x29\x00\x06\x00\x07\x00\x15\x00\x09\x00\x04\x00\x0a\x00\x06\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x11\x00\x03\x00\x0d\x00\x14\x00\x15\x00\x03\x00\x03\x00\x08\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x3a\x00\x08\x00\x04\x00\x2f\x00\x30\x00\x03\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x03\x00\x4c\x00\x01\x00\x0c\x00\x07\x00\x0e\x00\x09\x00\x03\x00\x21\x00\x4f\x00\x0d\x00\x24\x00\x25\x00\x10\x00\x11\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x0a\x00\x05\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x07\x00\x02\x00\x09\x00\x4f\x00\x0b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x10\x00\x11\x00\x03\x00\x3a\x00\x0c\x00\x06\x00\x07\x00\x03\x00\x09\x00\x0e\x00\x1a\x00\x1b\x00\x02\x00\x0d\x00\x02\x00\x10\x00\x11\x00\x0e\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x1a\x00\x1b\x00\x07\x00\x05\x00\x09\x00\x4b\x00\x0b\x00\x34\x00\x4f\x00\x06\x00\x2f\x00\x10\x00\x11\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x0a\x00\x4f\x00\x03\x00\x09\x00\x1a\x00\x1b\x00\x07\x00\x4f\x00\x09\x00\x03\x00\x4f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x10\x00\x11\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x06\x00\x0a\x00\x03\x00\x1a\x00\x1b\x00\x03\x00\x07\x00\x04\x00\x09\x00\x03\x00\x01\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x10\x00\x11\x00\x4f\x00\x1e\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1a\x00\x1b\x00\x04\x00\x4f\x00\x04\x00\x04\x00\x12\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x2f\x00\x30\x00\x31\x00\x21\x00\x03\x00\x08\x00\x24\x00\x25\x00\x2f\x00\x02\x00\x4f\x00\x46\x00\x3b\x00\x04\x00\x3d\x00\x0a\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x01\x00\x26\x00\x27\x00\x28\x00\x01\x00\x04\x00\x0c\x00\x01\x00\x27\x00\x02\x00\x29\x00\x2a\x00\x2b\x00\x21\x00\x2d\x00\x34\x00\x24\x00\x25\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x35\x00\x36\x00\x37\x00\x38\x00\x06\x00\x01\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x03\x00\x01\x00\x4f\x00\x04\x00\x45\x00\x01\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x05\x00\x2d\x00\x03\x00\x3a\x00\x4f\x00\x39\x00\x4f\x00\x39\x00\x04\x00\x35\x00\x36\x00\x37\x00\x38\x00\x04\x00\x01\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x21\x00\x40\x00\x0f\x00\x24\x00\x25\x00\x04\x00\x45\x00\x04\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x21\x00\x2d\x00\x01\x00\x24\x00\x25\x00\x01\x00\x4f\x00\x04\x00\x03\x00\x35\x00\x36\x00\x37\x00\x38\x00\x01\x00\x12\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x0a\x00\x06\x00\x0d\x00\x13\x00\x45\x00\x14\x00\x27\x00\x48\x00\x29\x00\x2a\x00\x2b\x00\x1b\x00\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x22\x00\x23\x00\x35\x00\x36\x00\x37\x00\x38\x00\x0d\x00\x04\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x04\x00\x40\x00\x01\x00\x4f\x00\x18\x00\x03\x00\x45\x00\x19\x00\x4f\x00\x48\x00\x0a\x00\x08\x00\x4f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4c\x00\x0d\x00\x03\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0c\x00\x08\x00\x34\x00\x12\x00\x0a\x00\x06\x00\x18\x00\x39\x00\x06\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4f\x00\x42\x00\x43\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2f\x00\x01\x00\x06\x00\x39\x00\x4d\x00\x4f\x00\x0d\x00\x34\x00\x4f\x00\x4f\x00\x01\x00\x4f\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x2f\x00\x30\x00\x02\x00\x42\x00\x43\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x52\x00\x34\x00\x03\x00\x03\x00\x03\x00\x03\x00\x39\x00\x3a\x00\x4f\x00\x3c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x18\x00\x15\x00\x34\x00\x52\x00\x16\x00\x26\x00\x27\x00\x39\x00\x3a\x00\x0d\x00\x3c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x4c\x00\x30\x00\xff\xff\x34\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x34\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\x37\x00\x38\x00\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x13\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\xff\xff\x1b\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x22\x00\x23\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x28\x00\xff\xff\x39\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x28\x00\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x26\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x03\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x34\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x2e\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x34\x00\x26\x00\x27\x00\xff\xff\x1c\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\x26\x00\x27\x00\xff\xff\x34\x00\xff\xff\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x34\x00\x26\x00\x27\x00\x03\x00\xff\xff\x35\x00\x36\x00\x37\x00\x38\x00\x03\x00\xff\xff\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x34\x00\x40\x00\xff\xff\xff\xff\xff\xff\x14\x00\x45\x00\x03\x00\xff\xff\x48\x00\x13\x00\x03\x00\xff\xff\x1c\x00\xff\xff\xff\xff\x03\x00\xff\xff\x1b\x00\x22\x00\x23\x00\x03\x00\xff\xff\x13\x00\xff\xff\x22\x00\x23\x00\x13\x00\xff\xff\xff\xff\x03\x00\x1b\x00\x13\x00\x03\x00\xff\xff\x1b\x00\xff\xff\x13\x00\x22\x00\x23\x00\x1b\x00\xff\xff\x22\x00\x23\x00\x03\x00\x1b\x00\x13\x00\x22\x00\x23\x00\x13\x00\x03\x00\xff\xff\x22\x00\x23\x00\x1b\x00\x03\x00\xff\xff\x1b\x00\xff\xff\xff\xff\x13\x00\x22\x00\x23\x00\xff\xff\x22\x00\x23\x00\x13\x00\x03\x00\x1b\x00\x03\x00\xff\xff\xff\xff\x14\x00\xff\xff\x1b\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x1c\x00\x22\x00\x23\x00\x13\x00\xff\xff\x13\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1b\x00\x25\x00\xff\xff\xff\xff\x28\x00\x22\x00\x23\x00\x22\x00\x23\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x15\x00\x40\x00\xf4\x00\x45\x00\x16\x00\x46\x00\x17\x00\x40\x00\x61\x00\x41\x00\xf4\x00\x84\x00\x18\x00\x19\x00\x1a\x00\x40\x00\x83\x01\x41\x00\x81\x00\x40\x00\x1b\x00\x41\x00\x47\x00\xd2\x01\x6a\x00\x40\x00\xe0\xff\x41\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x40\x00\x22\x00\x41\x00\x71\x00\x23\x00\x81\x00\xf7\x00\x24\x00\x37\x00\x10\x01\x75\x00\x40\x00\xf8\x00\x41\x00\xf4\x00\x26\x00\x33\x00\x10\x01\x6e\x01\x77\x01\x4f\x00\x50\x00\x51\x00\x52\x00\xab\x00\x27\x00\x28\x00\x2e\x00\x6f\x01\x69\x00\x29\x00\x2a\x00\x82\x00\x6a\x00\xac\x00\x2c\x00\x2b\x00\x2e\x00\x2e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xd8\x00\x15\x00\x2e\x00\xe0\xff\xff\xff\x16\x00\x2e\x00\x17\x00\x42\x00\xed\x00\x2e\x00\xea\x00\xd9\x00\x18\x00\x19\x00\x1a\x00\xeb\x00\x65\x00\x42\x00\x43\x00\x65\x00\x1b\x00\xc7\x00\x56\x01\x2e\x00\x2c\x00\x2c\x00\xda\x00\x2e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x2e\x00\x22\x00\x7b\x00\xdc\x00\x23\x00\x2e\x00\x2e\x00\x24\x00\x2e\x00\x78\x01\x25\x00\x35\x00\x36\x00\x35\x00\x7b\x00\x26\x00\x7c\x00\x7d\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x7e\x00\x62\x01\xcc\x01\x27\x00\x28\x00\x63\x01\x7c\x00\x7d\x00\x29\x00\x2a\x00\x6a\x00\xe4\x00\x66\x00\x34\x01\x2b\x00\x66\x00\x9e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xc7\x00\xf6\xff\x84\x01\x16\x00\x96\x01\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\xee\x00\x18\x00\x19\x00\x1a\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1b\x00\xaf\x00\xb0\x00\xc1\x00\xf9\x00\x97\x01\xc2\x01\x7f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xcd\x01\x22\x00\xc2\x00\x49\x01\x23\x00\x5c\x00\x2e\x00\x24\x00\x04\x01\x95\x01\x75\x00\xc5\x01\xfa\x00\x65\x00\xc7\x00\x26\x00\x5c\x00\x5c\x00\x8f\x01\x99\x01\xa2\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x27\x00\x28\x00\xa3\x00\x36\xff\xca\x01\x29\x00\x2a\x00\xbd\x01\x12\x00\x36\xff\xb7\x01\x2b\x00\xa4\x00\x4b\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xc7\x00\x7e\x01\x41\x01\x16\x00\x9a\x01\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\xc1\x01\x18\x00\x19\x00\x1a\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x8c\x01\x1b\x00\x66\x00\x67\x00\x5c\x00\xaf\x00\xb0\x00\xc1\x00\x16\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x17\x01\x22\x00\xee\x00\xe4\x00\x23\x00\xc2\x00\x5b\x01\x24\x00\x8d\x01\xe5\x00\x25\x00\xe6\x00\xc5\x00\xab\x01\xbf\x01\x26\x00\xe7\x00\xe8\x00\xc6\x00\x5d\x00\xa2\x00\x08\x01\x5e\x00\x2c\x01\xad\x01\x27\x00\x28\x00\xa3\x00\xa2\x00\x93\x01\x29\x00\x2a\x00\xe4\x00\x94\x01\xb2\x01\x9e\x01\x2b\x00\xa4\x00\xa5\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\x86\x01\x74\x01\x6e\x00\x4c\x00\x6f\x00\x17\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x98\x00\x18\x00\x19\x00\x1a\x00\x9c\x01\x96\x01\x17\x00\xa8\x01\x4f\x00\x50\x00\x51\x00\xc0\x00\x4d\x00\x19\x00\x1a\x00\xb3\x01\x9d\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x8c\x01\x22\x00\x97\x01\x98\x01\x23\x00\x4e\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x23\x00\xf9\x00\x16\x01\x5d\x00\x0c\x01\xa2\x00\x5e\x00\x76\x00\x8d\x01\x17\x01\x27\x00\x28\x00\x6f\x01\x18\x01\x8e\x01\x29\x00\x2a\x00\xaf\x00\xb0\x00\xc1\x00\x57\x01\x2b\x00\x0d\x01\xfa\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xfb\x00\x9c\x01\x5e\x01\xc2\x00\xc3\x00\xe4\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\x0c\x01\x60\x01\xa2\x00\x4c\x00\x6c\x01\x17\x00\x73\x01\x74\x01\x7f\x01\x18\x01\x98\x00\x18\x00\x19\x00\x1a\x00\x9c\x01\x71\x01\x17\x00\xb9\x01\x0d\x01\x81\x01\x30\xff\x98\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x0e\x01\x17\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4d\x00\x19\x00\x1a\x00\x90\x00\x23\x00\x91\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x72\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x23\x00\x7f\x01\x2f\x00\x30\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x75\x01\xbc\x01\x5c\x00\x81\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x79\x01\xf4\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x23\x01\xfc\x00\x91\x00\xaf\x00\xb0\x00\xc1\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x15\x00\xb8\x00\x49\x00\xa2\x00\x4c\x00\x1e\x01\x17\x00\xc2\x00\x12\x01\xb7\x00\x32\x01\x98\x00\x18\x00\x19\x00\x1a\x00\x4c\x00\x12\x00\x17\x00\xb9\x00\x3a\x01\x40\x01\x51\x01\x15\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x25\x01\x17\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x18\x00\x19\x00\x1a\x00\x43\x01\x23\x00\xb8\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x32\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xb9\x00\x7f\x01\x33\x00\xba\x00\x23\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x7c\x01\x80\x01\x7d\x01\x81\x01\x4f\x00\x50\x00\x51\x00\x52\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xa6\x00\x4f\x00\x50\x00\x51\x00\xae\x00\xad\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x9a\x00\xb5\x00\x9b\x00\xaf\x00\xb0\x00\x50\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x4b\x00\xbf\x00\xc7\x00\xdd\x00\x4c\x00\xde\x00\x17\x00\xdf\x00\xaf\x00\xb0\x00\xb1\x00\x15\x00\x4d\x00\x19\x00\x1a\x00\x4c\x00\x53\x00\x17\x00\xe0\x00\xe1\x00\xb2\x00\xe2\x00\x4f\x01\x18\x00\x19\x00\x1a\x00\xaf\x00\xb0\x00\xb6\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x23\x00\x24\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x16\x01\x38\x00\x55\x00\x90\x00\x23\x00\x91\x00\x56\x00\x17\x01\x57\x00\x90\x00\x47\x00\x91\x00\x1a\x01\x55\xff\x64\x00\x58\x00\x59\x00\x6d\x00\x92\x00\x55\xff\x55\xff\xd2\x01\x3b\x01\xcc\x01\x55\xff\x5a\x00\x5b\x00\x1b\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x7b\x01\xcf\x01\xd0\x01\xaf\x00\x59\x01\x7f\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x55\x00\x06\x00\xc8\x01\x85\x01\x56\x00\x81\x01\x57\x00\xc9\x01\x5d\x00\x2e\x00\x1a\x01\x5e\x00\x76\x00\x58\x00\x59\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xb9\x01\xca\x01\x55\x00\x5a\x00\x5b\x00\x1b\x01\x56\x00\xbb\x01\x57\x00\x2e\x00\xb5\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x58\x00\x59\x00\x55\x00\x7b\x01\xc4\x01\x63\x01\x56\x00\xc5\x01\x57\x00\xaa\x01\x5a\x00\x5b\x00\x62\x01\xab\x01\xaf\x01\x58\x00\x59\x00\xad\x01\x0b\x00\x0c\x00\x8a\x00\x8b\x00\x8c\x00\x55\x00\x11\x00\x5a\x00\x5b\x00\x56\x00\xb1\x01\x57\x00\xb2\x01\xb5\x00\x12\x00\x2e\x00\xb5\x01\xb6\x01\x58\x00\x59\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\xb7\x01\x2e\x00\x55\x00\x7e\x01\x5a\x00\x5b\x00\x56\x00\x2e\x00\x57\x00\x84\x01\x2e\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x58\x00\x59\x00\x89\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x77\x01\x8c\x01\x55\x00\x5a\x00\x5b\x00\x91\x01\x56\x00\xa0\x01\x57\x00\x5c\x00\xa1\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\x58\x00\x59\x00\x2e\x00\xa2\x01\xa5\x01\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x5a\x00\x5b\x00\x45\x01\x2e\x00\x46\x01\xd4\x01\x48\x01\x06\x00\x2c\x00\x2d\x00\x2e\x00\xaf\x00\xb0\x00\xb1\x00\x5d\x00\x5c\x00\x47\x01\x5e\x00\x42\x01\x4d\x01\x4e\x01\x2e\x00\x5c\x00\xb2\x00\x5d\x01\xb3\x00\x5e\x01\x2e\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\x60\x01\x0b\x00\x0c\x00\x86\x00\x64\x01\xd1\x01\x65\x01\x66\x01\xc9\x00\x67\x01\xca\x00\xcb\x00\xcc\x00\x5d\x00\xcd\x00\x12\x00\x5e\x00\xa7\x00\x06\x00\x2c\x00\x2d\x00\x2e\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x63\x01\x68\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x69\x01\xd6\x00\x5c\x00\x6c\x01\x2e\x00\xbc\x01\xd7\x00\x71\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x79\x01\xcd\x00\x75\x00\x7b\x01\x2e\x00\xec\x00\x2e\x00\xed\x00\x11\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\x14\x01\x15\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x5d\x00\xd6\x00\x9b\x00\x5e\x00\x5f\x00\xc1\x01\xd7\x00\x1c\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x5d\x00\xcd\x00\x1d\x01\x5e\x00\x76\x00\x1e\x01\x2e\x00\x20\x01\xee\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x21\x01\x27\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x22\x01\xd6\x00\x25\x01\x28\x01\x2a\x01\xef\x00\xd7\x00\x29\x01\xc9\x00\xd8\x00\xca\x00\xcb\x00\xcc\x00\x87\x01\xcd\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xf1\x00\xf2\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x81\x00\x2f\x01\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x30\x01\xd6\x00\x31\x01\x2e\x00\x32\x01\x34\x01\xd7\x00\x37\x01\x2e\x00\xd8\x00\x3d\x01\x40\x01\x2e\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x06\x00\x81\x00\x85\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x01\x11\x00\x8f\x00\x4f\x00\x50\x00\x51\x00\xae\x00\x94\x00\x95\x00\x12\x00\x9c\x00\x99\x00\x9d\x00\xa0\x00\x13\x00\xa1\x00\x9e\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x2e\x00\x53\x01\xa6\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x01\x11\x00\xa9\x00\xaa\x00\x91\x00\xa2\x00\x2c\x00\x2e\x00\xbc\x00\x12\x00\x2e\x00\x2e\x00\xdc\x00\x2e\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xaf\x00\x5a\x01\xe4\x00\x53\x01\x54\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x38\x01\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x40\x00\xff\xff\x12\x00\x49\x00\x4e\x00\x4f\x00\x63\x00\x13\x00\x6b\x00\x2e\x00\x39\x01\x06\x00\x07\x00\x08\x00\x71\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x6a\x00\x11\x00\x06\x00\x07\x00\x08\x00\x92\x00\x0a\x00\x78\x00\x79\x00\x12\x00\xff\xff\x7a\x00\x0b\x00\x7f\x00\x13\x00\x6b\x00\x81\x00\x6c\x00\x06\x00\x07\x00\x08\x00\x71\x00\x0a\x00\x06\x00\x32\x00\x00\x00\x12\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x61\x00\x12\x00\x00\x00\x00\x00\x66\x00\xa8\x01\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x12\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x66\x00\x73\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbd\x00\x11\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xc6\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbe\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa5\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xaf\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x89\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x8a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x92\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa2\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xa3\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x48\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x4a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x58\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2a\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2d\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x35\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x37\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x3e\x01\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x85\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x89\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x8d\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xbc\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x72\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xee\x00\x00\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x63\x00\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\xef\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x69\x01\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\xf1\x00\xf2\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x0c\x00\x87\x00\x00\x00\x13\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x0c\x00\x88\x00\x00\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x95\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xee\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x12\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x96\x00\x00\x00\x02\x01\x00\x00\x08\x01\x00\x00\x12\x00\x0b\x00\xac\x00\x00\x00\x09\x01\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x0b\x01\x05\x01\x0b\x00\x61\x00\x00\x00\x12\x00\x00\x00\xc9\x00\x00\x00\xca\x00\xcb\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x12\x00\x0b\x00\x7f\x00\xee\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xee\x00\x00\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\x12\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x02\x01\xd7\x00\xee\x00\x00\x00\xd8\x00\xef\x00\xee\x00\x00\x00\x91\x01\x00\x00\x00\x00\xee\x00\x00\x00\x6a\x01\x04\x01\x05\x01\xee\x00\x00\x00\xef\x00\x00\x00\xf1\x00\xf2\x00\xef\x00\x00\x00\x00\x00\xee\x00\xf0\x00\xef\x00\xee\x00\x00\x00\xf5\x00\x00\x00\xef\x00\xf1\x00\xf2\x00\xf8\x00\x00\x00\xf1\x00\xf2\x00\xee\x00\xfd\x00\xef\x00\xf1\x00\xf2\x00\xef\x00\xee\x00\x00\x00\xf1\x00\xf2\x00\xfe\x00\xee\x00\x00\x00\xff\x00\x00\x00\x00\x00\xef\x00\xf1\x00\xf2\x00\x00\x00\xf1\x00\xf2\x00\xef\x00\xee\x00\x00\x01\xee\x00\x00\x00\x00\x00\x02\x01\x00\x00\x01\x01\xf1\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x03\x01\xf1\x00\xf2\x00\xef\x00\x00\x00\xef\x00\x04\x01\x05\x01\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x07\x01\x3a\x00\x00\x00\x00\x00\x3b\x00\xf1\x00\xf2\x00\xf1\x00\xf2\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (4, 241) [ + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188), + (189 , happyReduce_189), + (190 , happyReduce_190), + (191 , happyReduce_191), + (192 , happyReduce_192), + (193 , happyReduce_193), + (194 , happyReduce_194), + (195 , happyReduce_195), + (196 , happyReduce_196), + (197 , happyReduce_197), + (198 , happyReduce_198), + (199 , happyReduce_199), + (200 , happyReduce_200), + (201 , happyReduce_201), + (202 , happyReduce_202), + (203 , happyReduce_203), + (204 , happyReduce_204), + (205 , happyReduce_205), + (206 , happyReduce_206), + (207 , happyReduce_207), + (208 , happyReduce_208), + (209 , happyReduce_209), + (210 , happyReduce_210), + (211 , happyReduce_211), + (212 , happyReduce_212), + (213 , happyReduce_213), + (214 , happyReduce_214), + (215 , happyReduce_215), + (216 , happyReduce_216), + (217 , happyReduce_217), + (218 , happyReduce_218), + (219 , happyReduce_219), + (220 , happyReduce_220), + (221 , happyReduce_221), + (222 , happyReduce_222), + (223 , happyReduce_223), + (224 , happyReduce_224), + (225 , happyReduce_225), + (226 , happyReduce_226), + (227 , happyReduce_227), + (228 , happyReduce_228), + (229 , happyReduce_229), + (230 , happyReduce_230), + (231 , happyReduce_231), + (232 , happyReduce_232), + (233 , happyReduce_233), + (234 , happyReduce_234), + (235 , happyReduce_235), + (236 , happyReduce_236), + (237 , happyReduce_237), + (238 , happyReduce_238), + (239 , happyReduce_239), + (240 , happyReduce_240), + (241 , happyReduce_241) + ] + +happy_n_terms = 83 :: Int +happy_n_nonterms = 74 :: Int + +happyReduce_4 = happySpecReduce_1 0# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> + happyIn7 + ((read happy_var_1) :: Integer + )} + +happyReduce_5 = happySpecReduce_1 1# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> + happyIn8 + (happy_var_1 + )} + +happyReduce_6 = happySpecReduce_1 2# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> + happyIn9 + ((read happy_var_1) :: Double + )} + +happyReduce_7 = happySpecReduce_1 3# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn10 + (PIdent (mkPosToken happy_var_1) + )} + +happyReduce_8 = happySpecReduce_1 4# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (T_LString happy_var_1)) -> + happyIn11 + (LString (happy_var_1) + )} + +happyReduce_9 = happySpecReduce_1 5# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn12 + (Gr (reverse happy_var_1) + )} + +happyReduce_10 = happySpecReduce_0 6# happyReduction_10 +happyReduction_10 = happyIn13 + ([] + ) + +happyReduce_11 = happySpecReduce_2 6# happyReduction_11 +happyReduction_11 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn13 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_12 = happySpecReduce_2 7# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + happyIn14 + (happy_var_1 + )} + +happyReduce_13 = happyReduce 4# 7# happyReduction_13 +happyReduction_13 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut16 happy_x_4 of { happy_var_4 -> + happyIn14 + (MModule happy_var_1 happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_14 = happySpecReduce_2 8# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15 + (MAbstract happy_var_2 + )} + +happyReduce_15 = happySpecReduce_2 8# happyReduction_15 +happyReduction_15 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15 + (MResource happy_var_2 + )} + +happyReduce_16 = happySpecReduce_2 8# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15 + (MGrammar happy_var_2 + )} + +happyReduce_17 = happySpecReduce_2 8# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15 + (MInterface happy_var_2 + )} + +happyReduce_18 = happyReduce 4# 8# happyReduction_18 +happyReduction_18 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn15 + (MConcrete happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_19 = happyReduce 4# 8# happyReduction_19 +happyReduction_19 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn15 + (MInstance happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_20 = happyReduce 5# 9# happyReduction_20 +happyReduction_20 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOut17 happy_x_4 of { happy_var_4 -> + happyIn16 + (MBody happy_var_1 happy_var_2 (reverse happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_21 = happySpecReduce_1 9# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn16 + (MNoBody happy_var_1 + )} + +happyReduce_22 = happySpecReduce_3 9# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn16 + (MWith happy_var_1 happy_var_3 + )}} + +happyReduce_23 = happyReduce 8# 9# happyReduction_23 +happyReduction_23 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut24 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + case happyOut20 happy_x_5 of { happy_var_5 -> + case happyOut17 happy_x_7 of { happy_var_7 -> + happyIn16 + (MWithBody happy_var_1 happy_var_3 happy_var_5 (reverse happy_var_7) + ) `HappyStk` happyRest}}}} + +happyReduce_24 = happyReduce 5# 9# happyReduction_24 +happyReduction_24 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_3 of { happy_var_3 -> + case happyOut19 happy_x_5 of { happy_var_5 -> + happyIn16 + (MWithE happy_var_1 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_25 = happyReduce 10# 9# happyReduction_25 +happyReduction_25 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_3 of { happy_var_3 -> + case happyOut19 happy_x_5 of { happy_var_5 -> + case happyOut20 happy_x_7 of { happy_var_7 -> + case happyOut17 happy_x_9 of { happy_var_9 -> + happyIn16 + (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 (reverse happy_var_9) + ) `HappyStk` happyRest}}}}} + +happyReduce_26 = happySpecReduce_2 9# happyReduction_26 +happyReduction_26 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn16 + (MReuse happy_var_2 + )} + +happyReduce_27 = happySpecReduce_2 9# happyReduction_27 +happyReduction_27 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn16 + (MUnion happy_var_2 + )} + +happyReduce_28 = happySpecReduce_0 10# happyReduction_28 +happyReduction_28 = happyIn17 + ([] + ) + +happyReduce_29 = happySpecReduce_2 10# happyReduction_29 +happyReduction_29 happy_x_2 + happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_2 of { happy_var_2 -> + happyIn17 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_30 = happySpecReduce_2 11# happyReduction_30 +happyReduction_30 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn18 + (Ext happy_var_1 + )} + +happyReduce_31 = happySpecReduce_0 11# happyReduction_31 +happyReduction_31 = happyIn18 + (NoExt + ) + +happyReduce_32 = happySpecReduce_0 12# happyReduction_32 +happyReduction_32 = happyIn19 + ([] + ) + +happyReduce_33 = happySpecReduce_1 12# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn19 + ((:[]) happy_var_1 + )} + +happyReduce_34 = happySpecReduce_3 12# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_3 of { happy_var_3 -> + happyIn19 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_35 = happySpecReduce_0 13# happyReduction_35 +happyReduction_35 = happyIn20 + (NoOpens + ) + +happyReduce_36 = happySpecReduce_3 13# happyReduction_36 +happyReduction_36 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn20 + (OpenIn happy_var_2 + )} + +happyReduce_37 = happySpecReduce_1 14# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn21 + (OName happy_var_1 + )} + +happyReduce_38 = happyReduce 5# 14# happyReduction_38 +happyReduction_38 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn21 + (OQual happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_39 = happySpecReduce_0 15# happyReduction_39 +happyReduction_39 = happyIn22 + (CMCompl + ) + +happyReduce_40 = happySpecReduce_1 15# happyReduction_40 +happyReduction_40 happy_x_1 + = happyIn22 + (CMIncompl + ) + +happyReduce_41 = happySpecReduce_0 16# happyReduction_41 +happyReduction_41 = happyIn23 + ([] + ) + +happyReduce_42 = happySpecReduce_1 16# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + happyIn23 + ((:[]) happy_var_1 + )} + +happyReduce_43 = happySpecReduce_3 16# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn23 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_44 = happySpecReduce_1 17# happyReduction_44 +happyReduction_44 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn24 + (IAll happy_var_1 + )} + +happyReduce_45 = happyReduce 4# 17# happyReduction_45 +happyReduction_45 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn24 + (ISome happy_var_1 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_46 = happyReduce 5# 17# happyReduction_46 +happyReduction_46 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_4 of { happy_var_4 -> + happyIn24 + (IMinus happy_var_1 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_47 = happySpecReduce_2 18# happyReduction_47 +happyReduction_47 happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefCat happy_var_2 + )} + +happyReduce_48 = happySpecReduce_2 18# happyReduction_48 +happyReduction_48 happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefFun happy_var_2 + )} + +happyReduce_49 = happySpecReduce_2 18# happyReduction_49 +happyReduction_49 happy_x_2 + happy_x_1 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefFunData happy_var_2 + )} + +happyReduce_50 = happySpecReduce_2 18# happyReduction_50 +happyReduction_50 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefDef happy_var_2 + )} + +happyReduce_51 = happySpecReduce_2 18# happyReduction_51 +happyReduction_51 happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefData happy_var_2 + )} + +happyReduce_52 = happySpecReduce_2 18# happyReduction_52 +happyReduction_52 happy_x_2 + happy_x_1 + = case happyOut38 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefPar happy_var_2 + )} + +happyReduce_53 = happySpecReduce_2 18# happyReduction_53 +happyReduction_53 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefOper happy_var_2 + )} + +happyReduce_54 = happySpecReduce_2 18# happyReduction_54 +happyReduction_54 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefLincat happy_var_2 + )} + +happyReduce_55 = happySpecReduce_2 18# happyReduction_55 +happyReduction_55 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefLindef happy_var_2 + )} + +happyReduce_56 = happySpecReduce_2 18# happyReduction_56 +happyReduction_56 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefLin happy_var_2 + )} + +happyReduce_57 = happySpecReduce_3 18# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut34 happy_x_3 of { happy_var_3 -> + happyIn25 + (DefPrintCat happy_var_3 + )} + +happyReduce_58 = happySpecReduce_3 18# happyReduction_58 +happyReduction_58 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut34 happy_x_3 of { happy_var_3 -> + happyIn25 + (DefPrintFun happy_var_3 + )} + +happyReduce_59 = happySpecReduce_2 18# happyReduction_59 +happyReduction_59 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefFlag happy_var_2 + )} + +happyReduce_60 = happySpecReduce_2 18# happyReduction_60 +happyReduction_60 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefPrintOld happy_var_2 + )} + +happyReduce_61 = happySpecReduce_2 18# happyReduction_61 +happyReduction_61 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefLintype happy_var_2 + )} + +happyReduce_62 = happySpecReduce_2 18# happyReduction_62 +happyReduction_62 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefPattern happy_var_2 + )} + +happyReduce_63 = happyReduce 7# 18# happyReduction_63 +happyReduction_63 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut17 happy_x_5 of { happy_var_5 -> + happyIn25 + (DefPackage happy_var_2 (reverse happy_var_5) + ) `HappyStk` happyRest}} + +happyReduce_64 = happySpecReduce_2 18# happyReduction_64 +happyReduction_64 happy_x_2 + happy_x_1 + = case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefVars happy_var_2 + )} + +happyReduce_65 = happySpecReduce_3 18# happyReduction_65 +happyReduction_65 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn25 + (DefTokenizer happy_var_2 + )} + +happyReduce_66 = happySpecReduce_3 19# happyReduction_66 +happyReduction_66 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn26 + (DDecl happy_var_1 happy_var_3 + )}} + +happyReduce_67 = happySpecReduce_3 19# happyReduction_67 +happyReduction_67 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn26 + (DDef happy_var_1 happy_var_3 + )}} + +happyReduce_68 = happyReduce 4# 19# happyReduction_68 +happyReduction_68 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut61 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_4 of { happy_var_4 -> + happyIn26 + (DPatt happy_var_1 happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_69 = happyReduce 5# 19# happyReduction_69 +happyReduction_69 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOut50 happy_x_5 of { happy_var_5 -> + happyIn26 + (DFull happy_var_1 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_70 = happySpecReduce_3 20# happyReduction_70 +happyReduction_70 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn27 + (FDecl happy_var_1 happy_var_3 + )}} + +happyReduce_71 = happySpecReduce_2 21# happyReduction_71 +happyReduction_71 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut76 happy_x_2 of { happy_var_2 -> + happyIn28 + (SimpleCatDef happy_var_1 (reverse happy_var_2) + )}} + +happyReduce_72 = happyReduce 4# 21# happyReduction_72 +happyReduction_72 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut76 happy_x_3 of { happy_var_3 -> + happyIn28 + (ListCatDef happy_var_2 (reverse happy_var_3) + ) `HappyStk` happyRest}} + +happyReduce_73 = happyReduce 7# 21# happyReduction_73 +happyReduction_73 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut76 happy_x_3 of { happy_var_3 -> + case happyOut7 happy_x_6 of { happy_var_6 -> + happyIn28 + (ListSizeCatDef happy_var_2 (reverse happy_var_3) happy_var_6 + ) `HappyStk` happyRest}}} + +happyReduce_74 = happySpecReduce_3 22# happyReduction_74 +happyReduction_74 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_3 of { happy_var_3 -> + happyIn29 + (DataDef happy_var_1 happy_var_3 + )}} + +happyReduce_75 = happySpecReduce_1 23# happyReduction_75 +happyReduction_75 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn30 + (DataId happy_var_1 + )} + +happyReduce_76 = happySpecReduce_3 23# happyReduction_76 +happyReduction_76 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn30 + (DataQId happy_var_1 happy_var_3 + )}} + +happyReduce_77 = happySpecReduce_0 24# happyReduction_77 +happyReduction_77 = happyIn31 + ([] + ) + +happyReduce_78 = happySpecReduce_1 24# happyReduction_78 +happyReduction_78 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn31 + ((:[]) happy_var_1 + )} + +happyReduce_79 = happySpecReduce_3 24# happyReduction_79 +happyReduction_79 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + case happyOut31 happy_x_3 of { happy_var_3 -> + happyIn31 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_80 = happySpecReduce_3 25# happyReduction_80 +happyReduction_80 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut39 happy_x_3 of { happy_var_3 -> + happyIn32 + (ParDefDir happy_var_1 happy_var_3 + )}} + +happyReduce_81 = happySpecReduce_1 25# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn32 + (ParDefAbs happy_var_1 + )} + +happyReduce_82 = happySpecReduce_2 26# happyReduction_82 +happyReduction_82 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut76 happy_x_2 of { happy_var_2 -> + happyIn33 + (ParConstr happy_var_1 (reverse happy_var_2) + )}} + +happyReduce_83 = happySpecReduce_2 27# happyReduction_83 +happyReduction_83 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + happyIn34 + ((:[]) happy_var_1 + )} + +happyReduce_84 = happySpecReduce_3 27# happyReduction_84 +happyReduction_84 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_3 of { happy_var_3 -> + happyIn34 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_85 = happySpecReduce_2 28# happyReduction_85 +happyReduction_85 happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn35 + ((:[]) happy_var_1 + )} + +happyReduce_86 = happySpecReduce_3 28# happyReduction_86 +happyReduction_86 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn35 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_87 = happySpecReduce_2 29# happyReduction_87 +happyReduction_87 happy_x_2 + happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + happyIn36 + ((:[]) happy_var_1 + )} + +happyReduce_88 = happySpecReduce_3 29# happyReduction_88 +happyReduction_88 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn36 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_89 = happySpecReduce_2 30# happyReduction_89 +happyReduction_89 happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn37 + ((:[]) happy_var_1 + )} + +happyReduce_90 = happySpecReduce_3 30# happyReduction_90 +happyReduction_90 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn37 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_91 = happySpecReduce_2 31# happyReduction_91 +happyReduction_91 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn38 + ((:[]) happy_var_1 + )} + +happyReduce_92 = happySpecReduce_3 31# happyReduction_92 +happyReduction_92 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + happyIn38 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_93 = happySpecReduce_0 32# happyReduction_93 +happyReduction_93 = happyIn39 + ([] + ) + +happyReduce_94 = happySpecReduce_1 32# happyReduction_94 +happyReduction_94 happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + happyIn39 + ((:[]) happy_var_1 + )} + +happyReduce_95 = happySpecReduce_3 32# happyReduction_95 +happyReduction_95 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut39 happy_x_3 of { happy_var_3 -> + happyIn39 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_96 = happySpecReduce_1 33# happyReduction_96 +happyReduction_96 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn40 + ((:[]) happy_var_1 + )} + +happyReduce_97 = happySpecReduce_3 33# happyReduction_97 +happyReduction_97 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn40 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_98 = happySpecReduce_1 34# happyReduction_98 +happyReduction_98 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn41 + (PIdentName happy_var_1 + )} + +happyReduce_99 = happySpecReduce_3 34# happyReduction_99 +happyReduction_99 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn41 + (ListName happy_var_2 + )} + +happyReduce_100 = happySpecReduce_1 35# happyReduction_100 +happyReduction_100 happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn42 + ((:[]) happy_var_1 + )} + +happyReduce_101 = happySpecReduce_3 35# happyReduction_101 +happyReduction_101 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn42 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_102 = happySpecReduce_3 36# happyReduction_102 +happyReduction_102 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn43 + (LDDecl happy_var_1 happy_var_3 + )}} + +happyReduce_103 = happySpecReduce_3 36# happyReduction_103 +happyReduction_103 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn43 + (LDDef happy_var_1 happy_var_3 + )}} + +happyReduce_104 = happyReduce 5# 36# happyReduction_104 +happyReduction_104 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOut50 happy_x_5 of { happy_var_5 -> + happyIn43 + (LDFull happy_var_1 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_105 = happySpecReduce_0 37# happyReduction_105 +happyReduction_105 = happyIn44 + ([] + ) + +happyReduce_106 = happySpecReduce_1 37# happyReduction_106 +happyReduction_106 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn44 + ((:[]) happy_var_1 + )} + +happyReduce_107 = happySpecReduce_3 37# happyReduction_107 +happyReduction_107 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + case happyOut44 happy_x_3 of { happy_var_3 -> + happyIn44 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_108 = happySpecReduce_1 38# happyReduction_108 +happyReduction_108 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn45 + (EPIdent happy_var_1 + )} + +happyReduce_109 = happySpecReduce_3 38# happyReduction_109 +happyReduction_109 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn45 + (EConstr happy_var_2 + )} + +happyReduce_110 = happySpecReduce_3 38# happyReduction_110 +happyReduction_110 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn45 + (ECons happy_var_2 + )} + +happyReduce_111 = happySpecReduce_1 38# happyReduction_111 +happyReduction_111 happy_x_1 + = case happyOut59 happy_x_1 of { happy_var_1 -> + happyIn45 + (ESort happy_var_1 + )} + +happyReduce_112 = happySpecReduce_1 38# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn45 + (EString happy_var_1 + )} + +happyReduce_113 = happySpecReduce_1 38# happyReduction_113 +happyReduction_113 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn45 + (EInt happy_var_1 + )} + +happyReduce_114 = happySpecReduce_1 38# happyReduction_114 +happyReduction_114 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn45 + (EFloat happy_var_1 + )} + +happyReduce_115 = happySpecReduce_1 38# happyReduction_115 +happyReduction_115 happy_x_1 + = happyIn45 + (EMeta + ) + +happyReduce_116 = happySpecReduce_2 38# happyReduction_116 +happyReduction_116 happy_x_2 + happy_x_1 + = happyIn45 + (EEmpty + ) + +happyReduce_117 = happySpecReduce_1 38# happyReduction_117 +happyReduction_117 happy_x_1 + = happyIn45 + (EData + ) + +happyReduce_118 = happyReduce 4# 38# happyReduction_118 +happyReduction_118 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut53 happy_x_3 of { happy_var_3 -> + happyIn45 + (EList happy_var_2 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_119 = happySpecReduce_3 38# happyReduction_119 +happyReduction_119 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn45 + (EStrings happy_var_2 + )} + +happyReduce_120 = happySpecReduce_3 38# happyReduction_120 +happyReduction_120 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut44 happy_x_2 of { happy_var_2 -> + happyIn45 + (ERecord happy_var_2 + )} + +happyReduce_121 = happySpecReduce_3 38# happyReduction_121 +happyReduction_121 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut67 happy_x_2 of { happy_var_2 -> + happyIn45 + (ETuple happy_var_2 + )} + +happyReduce_122 = happyReduce 4# 38# happyReduction_122 +happyReduction_122 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn45 + (EIndir happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_123 = happyReduce 5# 38# happyReduction_123 +happyReduction_123 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut50 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_4 of { happy_var_4 -> + happyIn45 + (ETyped happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_124 = happySpecReduce_3 38# happyReduction_124 +happyReduction_124 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_2 of { happy_var_2 -> + happyIn45 + (happy_var_2 + )} + +happyReduce_125 = happySpecReduce_1 38# happyReduction_125 +happyReduction_125 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn45 + (ELString happy_var_1 + )} + +happyReduce_126 = happySpecReduce_3 39# happyReduction_126 +happyReduction_126 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + happyIn46 + (EProj happy_var_1 happy_var_3 + )}} + +happyReduce_127 = happyReduce 5# 39# happyReduction_127 +happyReduction_127 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn46 + (EQConstr happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_128 = happyReduce 4# 39# happyReduction_128 +happyReduction_128 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn46 + (EQCons happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_129 = happySpecReduce_1 39# happyReduction_129 +happyReduction_129 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn46 + (happy_var_1 + )} + +happyReduce_130 = happySpecReduce_2 40# happyReduction_130 +happyReduction_130 happy_x_2 + happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut46 happy_x_2 of { happy_var_2 -> + happyIn47 + (EApp happy_var_1 happy_var_2 + )}} + +happyReduce_131 = happyReduce 4# 40# happyReduction_131 +happyReduction_131 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut70 happy_x_3 of { happy_var_3 -> + happyIn47 + (ETable happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_132 = happyReduce 5# 40# happyReduction_132 +happyReduction_132 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_2 of { happy_var_2 -> + case happyOut70 happy_x_4 of { happy_var_4 -> + happyIn47 + (ETTable happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_133 = happyReduce 5# 40# happyReduction_133 +happyReduction_133 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_2 of { happy_var_2 -> + case happyOut52 happy_x_4 of { happy_var_4 -> + happyIn47 + (EVTable happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_134 = happyReduce 6# 40# happyReduction_134 +happyReduction_134 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut50 happy_x_2 of { happy_var_2 -> + case happyOut70 happy_x_5 of { happy_var_5 -> + happyIn47 + (ECase happy_var_2 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_135 = happyReduce 4# 40# happyReduction_135 +happyReduction_135 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut52 happy_x_3 of { happy_var_3 -> + happyIn47 + (EVariants happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_136 = happyReduce 6# 40# happyReduction_136 +happyReduction_136 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOut74 happy_x_5 of { happy_var_5 -> + happyIn47 + (EPre happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_137 = happyReduce 4# 40# happyReduction_137 +happyReduction_137 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut52 happy_x_3 of { happy_var_3 -> + happyIn47 + (EStrs happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_138 = happySpecReduce_2 40# happyReduction_138 +happyReduction_138 happy_x_2 + happy_x_1 + = case happyOut54 happy_x_2 of { happy_var_2 -> + happyIn47 + (EPatt happy_var_2 + )} + +happyReduce_139 = happySpecReduce_3 40# happyReduction_139 +happyReduction_139 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut46 happy_x_3 of { happy_var_3 -> + happyIn47 + (EPattType happy_var_3 + )} + +happyReduce_140 = happySpecReduce_1 40# happyReduction_140 +happyReduction_140 happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn47 + (happy_var_1 + )} + +happyReduce_141 = happySpecReduce_2 40# happyReduction_141 +happyReduction_141 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn47 + (ELin happy_var_2 + )} + +happyReduce_142 = happySpecReduce_3 41# happyReduction_142 +happyReduction_142 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn48 + (ESelect happy_var_1 happy_var_3 + )}} + +happyReduce_143 = happySpecReduce_3 41# happyReduction_143 +happyReduction_143 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn48 + (ETupTyp happy_var_1 happy_var_3 + )}} + +happyReduce_144 = happySpecReduce_3 41# happyReduction_144 +happyReduction_144 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn48 + (EExtend happy_var_1 happy_var_3 + )}} + +happyReduce_145 = happySpecReduce_1 41# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn48 + (happy_var_1 + )} + +happyReduce_146 = happySpecReduce_3 42# happyReduction_146 +happyReduction_146 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + happyIn49 + (EGlue happy_var_1 happy_var_3 + )}} + +happyReduce_147 = happySpecReduce_1 42# happyReduction_147 +happyReduction_147 happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn49 + (happy_var_1 + )} + +happyReduce_148 = happySpecReduce_3 43# happyReduction_148 +happyReduction_148 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut49 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn50 + (EConcat happy_var_1 happy_var_3 + )}} + +happyReduce_149 = happyReduce 4# 43# happyReduction_149 +happyReduction_149 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut63 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_4 of { happy_var_4 -> + happyIn50 + (EAbstr happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_150 = happyReduce 5# 43# happyReduction_150 +happyReduction_150 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut63 happy_x_3 of { happy_var_3 -> + case happyOut50 happy_x_5 of { happy_var_5 -> + happyIn50 + (ECTable happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_151 = happySpecReduce_3 43# happyReduction_151 +happyReduction_151 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut64 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn50 + (EProd happy_var_1 happy_var_3 + )}} + +happyReduce_152 = happySpecReduce_3 43# happyReduction_152 +happyReduction_152 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn50 + (ETType happy_var_1 happy_var_3 + )}} + +happyReduce_153 = happyReduce 6# 43# happyReduction_153 +happyReduction_153 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut44 happy_x_3 of { happy_var_3 -> + case happyOut50 happy_x_6 of { happy_var_6 -> + happyIn50 + (ELet happy_var_3 happy_var_6 + ) `HappyStk` happyRest}} + +happyReduce_154 = happyReduce 4# 43# happyReduction_154 +happyReduction_154 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut44 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_4 of { happy_var_4 -> + happyIn50 + (ELetb happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_155 = happyReduce 5# 43# happyReduction_155 +happyReduction_155 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut44 happy_x_4 of { happy_var_4 -> + happyIn50 + (EWhere happy_var_1 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_156 = happyReduce 4# 43# happyReduction_156 +happyReduction_156 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut72 happy_x_3 of { happy_var_3 -> + happyIn50 + (EEqs happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_157 = happySpecReduce_3 43# happyReduction_157 +happyReduction_157 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut46 happy_x_2 of { happy_var_2 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn50 + (EExample happy_var_2 happy_var_3 + )}} + +happyReduce_158 = happySpecReduce_1 43# happyReduction_158 +happyReduction_158 happy_x_1 + = case happyOut49 happy_x_1 of { happy_var_1 -> + happyIn50 + (happy_var_1 + )} + +happyReduce_159 = happySpecReduce_1 44# happyReduction_159 +happyReduction_159 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn51 + (happy_var_1 + )} + +happyReduce_160 = happySpecReduce_0 45# happyReduction_160 +happyReduction_160 = happyIn52 + ([] + ) + +happyReduce_161 = happySpecReduce_1 45# happyReduction_161 +happyReduction_161 happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn52 + ((:[]) happy_var_1 + )} + +happyReduce_162 = happySpecReduce_3 45# happyReduction_162 +happyReduction_162 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut52 happy_x_3 of { happy_var_3 -> + happyIn52 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_163 = happySpecReduce_0 46# happyReduction_163 +happyReduction_163 = happyIn53 + (NilExp + ) + +happyReduce_164 = happySpecReduce_2 46# happyReduction_164 +happyReduction_164 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn53 + (ConsExp happy_var_1 happy_var_2 + )}} + +happyReduce_165 = happySpecReduce_1 47# happyReduction_165 +happyReduction_165 happy_x_1 + = happyIn54 + (PChar + ) + +happyReduce_166 = happySpecReduce_3 47# happyReduction_166 +happyReduction_166 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn54 + (PChars happy_var_2 + )} + +happyReduce_167 = happySpecReduce_2 47# happyReduction_167 +happyReduction_167 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn54 + (PMacro happy_var_2 + )} + +happyReduce_168 = happyReduce 4# 47# happyReduction_168 +happyReduction_168 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn54 + (PM happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_169 = happySpecReduce_1 47# happyReduction_169 +happyReduction_169 happy_x_1 + = happyIn54 + (PW + ) + +happyReduce_170 = happySpecReduce_1 47# happyReduction_170 +happyReduction_170 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn54 + (PV happy_var_1 + )} + +happyReduce_171 = happySpecReduce_3 47# happyReduction_171 +happyReduction_171 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn54 + (PCon happy_var_2 + )} + +happyReduce_172 = happySpecReduce_3 47# happyReduction_172 +happyReduction_172 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn54 + (PQ happy_var_1 happy_var_3 + )}} + +happyReduce_173 = happySpecReduce_1 47# happyReduction_173 +happyReduction_173 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn54 + (PInt happy_var_1 + )} + +happyReduce_174 = happySpecReduce_1 47# happyReduction_174 +happyReduction_174 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn54 + (PFloat happy_var_1 + )} + +happyReduce_175 = happySpecReduce_1 47# happyReduction_175 +happyReduction_175 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn54 + (PStr happy_var_1 + )} + +happyReduce_176 = happySpecReduce_3 47# happyReduction_176 +happyReduction_176 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut60 happy_x_2 of { happy_var_2 -> + happyIn54 + (PR happy_var_2 + )} + +happyReduce_177 = happySpecReduce_3 47# happyReduction_177 +happyReduction_177 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut68 happy_x_2 of { happy_var_2 -> + happyIn54 + (PTup happy_var_2 + )} + +happyReduce_178 = happySpecReduce_3 47# happyReduction_178 +happyReduction_178 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn54 + (happy_var_2 + )} + +happyReduce_179 = happySpecReduce_2 48# happyReduction_179 +happyReduction_179 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut61 happy_x_2 of { happy_var_2 -> + happyIn55 + (PC happy_var_1 happy_var_2 + )}} + +happyReduce_180 = happyReduce 4# 48# happyReduction_180 +happyReduction_180 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + case happyOut61 happy_x_4 of { happy_var_4 -> + happyIn55 + (PQC happy_var_1 happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_181 = happySpecReduce_2 48# happyReduction_181 +happyReduction_181 happy_x_2 + happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + happyIn55 + (PRep happy_var_1 + )} + +happyReduce_182 = happySpecReduce_3 48# happyReduction_182 +happyReduction_182 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn55 + (PAs happy_var_1 happy_var_3 + )}} + +happyReduce_183 = happySpecReduce_2 48# happyReduction_183 +happyReduction_183 happy_x_2 + happy_x_1 + = case happyOut54 happy_x_2 of { happy_var_2 -> + happyIn55 + (PNeg happy_var_2 + )} + +happyReduce_184 = happySpecReduce_1 48# happyReduction_184 +happyReduction_184 happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + happyIn55 + (happy_var_1 + )} + +happyReduce_185 = happySpecReduce_3 49# happyReduction_185 +happyReduction_185 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn56 + (PDisj happy_var_1 happy_var_3 + )}} + +happyReduce_186 = happySpecReduce_3 49# happyReduction_186 +happyReduction_186 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn56 + (PSeq happy_var_1 happy_var_3 + )}} + +happyReduce_187 = happySpecReduce_1 49# happyReduction_187 +happyReduction_187 happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn56 + (happy_var_1 + )} + +happyReduce_188 = happySpecReduce_3 50# happyReduction_188 +happyReduction_188 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_3 of { happy_var_3 -> + happyIn57 + (PA happy_var_1 happy_var_3 + )}} + +happyReduce_189 = happySpecReduce_1 51# happyReduction_189 +happyReduction_189 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn58 + (LPIdent happy_var_1 + )} + +happyReduce_190 = happySpecReduce_2 51# happyReduction_190 +happyReduction_190 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn58 + (LVar happy_var_2 + )} + +happyReduce_191 = happySpecReduce_1 52# happyReduction_191 +happyReduction_191 happy_x_1 + = happyIn59 + (Sort_Type + ) + +happyReduce_192 = happySpecReduce_1 52# happyReduction_192 +happyReduction_192 happy_x_1 + = happyIn59 + (Sort_PType + ) + +happyReduce_193 = happySpecReduce_1 52# happyReduction_193 +happyReduction_193 happy_x_1 + = happyIn59 + (Sort_Tok + ) + +happyReduce_194 = happySpecReduce_1 52# happyReduction_194 +happyReduction_194 happy_x_1 + = happyIn59 + (Sort_Str + ) + +happyReduce_195 = happySpecReduce_1 52# happyReduction_195 +happyReduction_195 happy_x_1 + = happyIn59 + (Sort_Strs + ) + +happyReduce_196 = happySpecReduce_0 53# happyReduction_196 +happyReduction_196 = happyIn60 + ([] + ) + +happyReduce_197 = happySpecReduce_1 53# happyReduction_197 +happyReduction_197 happy_x_1 + = case happyOut57 happy_x_1 of { happy_var_1 -> + happyIn60 + ((:[]) happy_var_1 + )} + +happyReduce_198 = happySpecReduce_3 53# happyReduction_198 +happyReduction_198 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_3 of { happy_var_3 -> + happyIn60 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_199 = happySpecReduce_1 54# happyReduction_199 +happyReduction_199 happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + happyIn61 + ((:[]) happy_var_1 + )} + +happyReduce_200 = happySpecReduce_2 54# happyReduction_200 +happyReduction_200 happy_x_2 + happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + case happyOut61 happy_x_2 of { happy_var_2 -> + happyIn61 + ((:) happy_var_1 happy_var_2 + )}} + +happyReduce_201 = happySpecReduce_1 55# happyReduction_201 +happyReduction_201 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn62 + (BPIdent happy_var_1 + )} + +happyReduce_202 = happySpecReduce_1 55# happyReduction_202 +happyReduction_202 happy_x_1 + = happyIn62 + (BWild + ) + +happyReduce_203 = happySpecReduce_0 56# happyReduction_203 +happyReduction_203 = happyIn63 + ([] + ) + +happyReduce_204 = happySpecReduce_1 56# happyReduction_204 +happyReduction_204 happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn63 + ((:[]) happy_var_1 + )} + +happyReduce_205 = happySpecReduce_3 56# happyReduction_205 +happyReduction_205 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_3 of { happy_var_3 -> + happyIn63 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_206 = happyReduce 5# 57# happyReduction_206 +happyReduction_206 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut63 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_4 of { happy_var_4 -> + happyIn64 + (DDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_207 = happySpecReduce_1 57# happyReduction_207 +happyReduction_207 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn64 + (DExp happy_var_1 + )} + +happyReduce_208 = happySpecReduce_1 58# happyReduction_208 +happyReduction_208 happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn65 + (TComp happy_var_1 + )} + +happyReduce_209 = happySpecReduce_1 59# happyReduction_209 +happyReduction_209 happy_x_1 + = case happyOut56 happy_x_1 of { happy_var_1 -> + happyIn66 + (PTComp happy_var_1 + )} + +happyReduce_210 = happySpecReduce_0 60# happyReduction_210 +happyReduction_210 = happyIn67 + ([] + ) + +happyReduce_211 = happySpecReduce_1 60# happyReduction_211 +happyReduction_211 happy_x_1 + = case happyOut65 happy_x_1 of { happy_var_1 -> + happyIn67 + ((:[]) happy_var_1 + )} + +happyReduce_212 = happySpecReduce_3 60# happyReduction_212 +happyReduction_212 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut65 happy_x_1 of { happy_var_1 -> + case happyOut67 happy_x_3 of { happy_var_3 -> + happyIn67 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_213 = happySpecReduce_0 61# happyReduction_213 +happyReduction_213 = happyIn68 + ([] + ) + +happyReduce_214 = happySpecReduce_1 61# happyReduction_214 +happyReduction_214 happy_x_1 + = case happyOut66 happy_x_1 of { happy_var_1 -> + happyIn68 + ((:[]) happy_var_1 + )} + +happyReduce_215 = happySpecReduce_3 61# happyReduction_215 +happyReduction_215 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut66 happy_x_1 of { happy_var_1 -> + case happyOut68 happy_x_3 of { happy_var_3 -> + happyIn68 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_216 = happySpecReduce_3 62# happyReduction_216 +happyReduction_216 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn69 + (Case happy_var_1 happy_var_3 + )}} + +happyReduce_217 = happySpecReduce_1 63# happyReduction_217 +happyReduction_217 happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + happyIn70 + ((:[]) happy_var_1 + )} + +happyReduce_218 = happySpecReduce_3 63# happyReduction_218 +happyReduction_218 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut70 happy_x_3 of { happy_var_3 -> + happyIn70 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_219 = happySpecReduce_3 64# happyReduction_219 +happyReduction_219 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn71 + (Equ happy_var_1 happy_var_3 + )}} + +happyReduce_220 = happySpecReduce_0 65# happyReduction_220 +happyReduction_220 = happyIn72 + ([] + ) + +happyReduce_221 = happySpecReduce_1 65# happyReduction_221 +happyReduction_221 happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn72 + ((:[]) happy_var_1 + )} + +happyReduce_222 = happySpecReduce_3 65# happyReduction_222 +happyReduction_222 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + case happyOut72 happy_x_3 of { happy_var_3 -> + happyIn72 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_223 = happySpecReduce_3 66# happyReduction_223 +happyReduction_223 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut50 happy_x_3 of { happy_var_3 -> + happyIn73 + (Alt happy_var_1 happy_var_3 + )}} + +happyReduce_224 = happySpecReduce_0 67# happyReduction_224 +happyReduction_224 = happyIn74 + ([] + ) + +happyReduce_225 = happySpecReduce_1 67# happyReduction_225 +happyReduction_225 happy_x_1 + = case happyOut73 happy_x_1 of { happy_var_1 -> + happyIn74 + ((:[]) happy_var_1 + )} + +happyReduce_226 = happySpecReduce_3 67# happyReduction_226 +happyReduction_226 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut73 happy_x_1 of { happy_var_1 -> + case happyOut74 happy_x_3 of { happy_var_3 -> + happyIn74 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_227 = happyReduce 5# 68# happyReduction_227 +happyReduction_227 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut63 happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_4 of { happy_var_4 -> + happyIn75 + (DDDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_228 = happySpecReduce_1 68# happyReduction_228 +happyReduction_228 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn75 + (DDExp happy_var_1 + )} + +happyReduce_229 = happySpecReduce_0 69# happyReduction_229 +happyReduction_229 = happyIn76 + ([] + ) + +happyReduce_230 = happySpecReduce_2 69# happyReduction_230 +happyReduction_230 happy_x_2 + happy_x_1 + = case happyOut76 happy_x_1 of { happy_var_1 -> + case happyOut75 happy_x_2 of { happy_var_2 -> + happyIn76 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_231 = happySpecReduce_2 70# happyReduction_231 +happyReduction_231 happy_x_2 + happy_x_1 + = case happyOut78 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn77 + (OldGr happy_var_1 (reverse happy_var_2) + )}} + +happyReduce_232 = happySpecReduce_0 71# happyReduction_232 +happyReduction_232 = happyIn78 + (NoIncl + ) + +happyReduce_233 = happySpecReduce_2 71# happyReduction_233 +happyReduction_233 happy_x_2 + happy_x_1 + = case happyOut80 happy_x_2 of { happy_var_2 -> + happyIn78 + (Incl happy_var_2 + )} + +happyReduce_234 = happySpecReduce_1 72# happyReduction_234 +happyReduction_234 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn79 + (FString happy_var_1 + )} + +happyReduce_235 = happySpecReduce_1 72# happyReduction_235 +happyReduction_235 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn79 + (FPIdent happy_var_1 + )} + +happyReduce_236 = happySpecReduce_2 72# happyReduction_236 +happyReduction_236 happy_x_2 + happy_x_1 + = case happyOut79 happy_x_2 of { happy_var_2 -> + happyIn79 + (FSlash happy_var_2 + )} + +happyReduce_237 = happySpecReduce_2 72# happyReduction_237 +happyReduction_237 happy_x_2 + happy_x_1 + = case happyOut79 happy_x_2 of { happy_var_2 -> + happyIn79 + (FDot happy_var_2 + )} + +happyReduce_238 = happySpecReduce_2 72# happyReduction_238 +happyReduction_238 happy_x_2 + happy_x_1 + = case happyOut79 happy_x_2 of { happy_var_2 -> + happyIn79 + (FMinus happy_var_2 + )} + +happyReduce_239 = happySpecReduce_2 72# happyReduction_239 +happyReduction_239 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut79 happy_x_2 of { happy_var_2 -> + happyIn79 + (FAddId happy_var_1 happy_var_2 + )}} + +happyReduce_240 = happySpecReduce_2 73# happyReduction_240 +happyReduction_240 happy_x_2 + happy_x_1 + = case happyOut79 happy_x_1 of { happy_var_1 -> + happyIn80 + ((:[]) happy_var_1 + )} + +happyReduce_241 = happySpecReduce_3 73# happyReduction_241 +happyReduction_241 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut79 happy_x_1 of { happy_var_1 -> + case happyOut80 happy_x_3 of { happy_var_3 -> + happyIn80 + ((:) happy_var_1 happy_var_3 + )}} + +happyNewToken action sts stk [] = + happyDoAction 82# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + PT _ (TS ";") -> cont 1#; + PT _ (TS "=") -> cont 2#; + PT _ (TS "{") -> cont 3#; + PT _ (TS "}") -> cont 4#; + PT _ (TS "**") -> cont 5#; + PT _ (TS ",") -> cont 6#; + PT _ (TS "(") -> cont 7#; + PT _ (TS ")") -> cont 8#; + PT _ (TS "[") -> cont 9#; + PT _ (TS "]") -> cont 10#; + PT _ (TS "-") -> cont 11#; + PT _ (TS ":") -> cont 12#; + PT _ (TS ".") -> cont 13#; + PT _ (TS "|") -> cont 14#; + PT _ (TS "%") -> cont 15#; + PT _ (TS "?") -> cont 16#; + PT _ (TS "<") -> cont 17#; + PT _ (TS ">") -> cont 18#; + PT _ (TS "!") -> cont 19#; + PT _ (TS "*") -> cont 20#; + PT _ (TS "+") -> cont 21#; + PT _ (TS "++") -> cont 22#; + PT _ (TS "\\") -> cont 23#; + PT _ (TS "->") -> cont 24#; + PT _ (TS "=>") -> cont 25#; + PT _ (TS "#") -> cont 26#; + PT _ (TS "_") -> cont 27#; + PT _ (TS "@") -> cont 28#; + PT _ (TS "$") -> cont 29#; + PT _ (TS "/") -> cont 30#; + PT _ (TS "Lin") -> cont 31#; + PT _ (TS "PType") -> cont 32#; + PT _ (TS "Str") -> cont 33#; + PT _ (TS "Strs") -> cont 34#; + PT _ (TS "Tok") -> cont 35#; + PT _ (TS "Type") -> cont 36#; + PT _ (TS "abstract") -> cont 37#; + PT _ (TS "case") -> cont 38#; + PT _ (TS "cat") -> cont 39#; + PT _ (TS "concrete") -> cont 40#; + PT _ (TS "data") -> cont 41#; + PT _ (TS "def") -> cont 42#; + PT _ (TS "flags") -> cont 43#; + PT _ (TS "fn") -> cont 44#; + PT _ (TS "fun") -> cont 45#; + PT _ (TS "grammar") -> cont 46#; + PT _ (TS "in") -> cont 47#; + PT _ (TS "include") -> cont 48#; + PT _ (TS "incomplete") -> cont 49#; + PT _ (TS "instance") -> cont 50#; + PT _ (TS "interface") -> cont 51#; + PT _ (TS "let") -> cont 52#; + PT _ (TS "lin") -> cont 53#; + PT _ (TS "lincat") -> cont 54#; + PT _ (TS "lindef") -> cont 55#; + PT _ (TS "lintype") -> cont 56#; + PT _ (TS "of") -> cont 57#; + PT _ (TS "open") -> cont 58#; + PT _ (TS "oper") -> cont 59#; + PT _ (TS "package") -> cont 60#; + PT _ (TS "param") -> cont 61#; + PT _ (TS "pattern") -> cont 62#; + PT _ (TS "pre") -> cont 63#; + PT _ (TS "printname") -> cont 64#; + PT _ (TS "resource") -> cont 65#; + PT _ (TS "reuse") -> cont 66#; + PT _ (TS "strs") -> cont 67#; + PT _ (TS "table") -> cont 68#; + PT _ (TS "tokenizer") -> cont 69#; + PT _ (TS "type") -> cont 70#; + PT _ (TS "union") -> cont 71#; + PT _ (TS "var") -> cont 72#; + PT _ (TS "variants") -> cont 73#; + PT _ (TS "where") -> cont 74#; + PT _ (TS "with") -> cont 75#; + PT _ (TI happy_dollar_dollar) -> cont 76#; + PT _ (TL happy_dollar_dollar) -> cont 77#; + PT _ (TD happy_dollar_dollar) -> cont 78#; + PT _ (T_PIdent _) -> cont 79#; + PT _ (T_LString happy_dollar_dollar) -> cont 80#; + _ -> cont 81#; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = (thenM) +happyReturn :: () => a -> Err a +happyReturn = (returnM) +happyThen1 m k tks = (thenM) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (returnM) a +happyError' :: () => [Token] -> Err a +happyError' = happyError + +pGrammar tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut12 x)) + +pModDef tks = happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut14 x)) + +pOldGrammar tks = happySomeParser where + happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut77 x)) + +pExp tks = happySomeParser where + happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut50 x)) + +happySeq = happyDontSeq + + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + _ -> " before " ++ unwords (map prToken (take 4 ts)) + +myLexer = tokens +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + +{-# LINE 59 "GenericTemplate.hs" #-} + +{-# LINE 68 "GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 127 "GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src-3.0/GF/Devel/Compile/PrintGF.hs b/src-3.0/GF/Devel/Compile/PrintGF.hs new file mode 100644 index 000000000..7eb63612a --- /dev/null +++ b/src-3.0/GF/Devel/Compile/PrintGF.hs @@ -0,0 +1,481 @@ +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module GF.Devel.Compile.PrintGF where + +-- pretty-printer generated by the BNF converter + +import GF.Devel.Compile.AbsGF +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + "[" :ts -> showChar '[' . rend i ts + "(" :ts -> showChar '(' . rend i ts + "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts + "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts + "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts + ";" :ts -> showChar ';' . new i . rend i ts + t : "," :ts -> showString t . space "," . rend i ts + t : ")" :ts -> showString t . showChar ')' . rend i ts + t : "]" :ts -> showString t . showChar ']' . rend i ts + t :ts -> space t . rend i ts + _ -> id + new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace + space t = showString t . (\s -> if null s then "" else (' ':s)) + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- the printer class does the job +class Print a where + prt :: Int -> a -> Doc + prtList :: [a] -> Doc + prtList = concatD . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') + prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q s = case s of + _ | s == q -> showChar '\\' . showChar s + '\\'-> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + _ -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + +instance Print LString where + prt _ (LString i) = doc (showString i) + + + +instance Print Grammar where + prt i e = case e of + Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs]) + + +instance Print ModDef where + prt i e = case e of + MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print ModType where + prt i e = case e of + MAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident]) + MResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident]) + MGrammar pident -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident]) + MInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident]) + MConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) + MInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) + + +instance Print ModBody where + prt i e = case e of + MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) + MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds]) + MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens]) + MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) + MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens]) + MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) + MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident]) + MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds]) + + +instance Print Extend where + prt i e = case e of + Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")]) + NoExt -> prPrec i 0 (concatD []) + + +instance Print Opens where + prt i e = case e of + NoOpens -> prPrec i 0 (concatD []) + OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")]) + + +instance Print Open where + prt i e = case e of + OName pident -> prPrec i 0 (concatD [prt 0 pident]) + OQual pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print ComplMod where + prt i e = case e of + CMCompl -> prPrec i 0 (concatD []) + CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")]) + + +instance Print Included where + prt i e = case e of + IAll pident -> prPrec i 0 (concatD [prt 0 pident]) + ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")]) + IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print TopDef where + prt i e = case e of + DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs]) + DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs]) + DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs]) + DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs]) + DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs]) + DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs]) + DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs]) + DefLincat defs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 defs]) + DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs]) + DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs]) + DefPrintCat defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 defs]) + DefPrintFun defs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 defs]) + DefFlag defs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 defs]) + DefPrintOld defs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 defs]) + DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs]) + DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs]) + DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")]) + DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs]) + DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Def where + prt i e = case e of + DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) + DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp]) + DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp]) + DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) + + prtList es = case es of + [x] -> (concatD [prt 0 x , doc (showString ";")]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print FunDef where + prt i e = case e of + FDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) + + prtList es = case es of + [x] -> (concatD [prt 0 x , doc (showString ";")]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print CatDef where + prt i e = case e of + SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) + ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")]) + ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")]) + + prtList es = case es of + [x] -> (concatD [prt 0 x , doc (showString ";")]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print DataDef where + prt i e = case e of + DataDef name dataconstrs -> prPrec i 0 (concatD [prt 0 name , doc (showString "=") , prt 0 dataconstrs]) + + prtList es = case es of + [x] -> (concatD [prt 0 x , doc (showString ";")]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print DataConstr where + prt i e = case e of + DataId pident -> prPrec i 0 (concatD [prt 0 pident]) + DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) + +instance Print ParDef where + prt i e = case e of + ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs]) + ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident]) + + prtList es = case es of + [x] -> (concatD [prt 0 x , doc (showString ";")]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print ParConstr where + prt i e = case e of + ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) + +instance Print Name where + prt i e = case e of + PIdentName pident -> prPrec i 0 (concatD [prt 0 pident]) + ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print LocDef where + prt i e = case e of + LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp]) + LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp]) + LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + EPIdent pident -> prPrec i 6 (concatD [prt 0 pident]) + EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) + ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")]) + ESort sort -> prPrec i 6 (concatD [prt 0 sort]) + EString str -> prPrec i 6 (concatD [prt 0 str]) + EInt n -> prPrec i 6 (concatD [prt 0 n]) + EFloat d -> prPrec i 6 (concatD [prt 0 d]) + EMeta -> prPrec i 6 (concatD [doc (showString "?")]) + EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")]) + EData -> prPrec i 6 (concatD [doc (showString "data")]) + EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")]) + EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) + ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")]) + ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")]) + EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")]) + ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")]) + EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label]) + EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")]) + EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) + EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp]) + ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")]) + ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")]) + EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")]) + ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")]) + EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")]) + EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")]) + EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")]) + EPatt patt -> prPrec i 4 (concatD [doc (showString "pattern") , prt 2 patt]) + EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , doc (showString "type") , prt 5 exp]) + ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp]) + ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp]) + EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp]) + EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp]) + EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp]) + EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp]) + ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp]) + EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp]) + ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp]) + ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp]) + ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp]) + EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")]) + EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")]) + EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str]) + ELString lstring -> prPrec i 6 (concatD [prt 0 lstring]) + ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Exps where + prt i e = case e of + NilExp -> prPrec i 0 (concatD []) + ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps]) + + +instance Print Patt where + prt i e = case e of + PChar -> prPrec i 2 (concatD [doc (showString "?")]) + PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) + PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident]) + PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) + PW -> prPrec i 2 (concatD [doc (showString "_")]) + PV pident -> prPrec i 2 (concatD [prt 0 pident]) + PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) + PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) + PInt n -> prPrec i 2 (concatD [prt 0 n]) + PFloat d -> prPrec i 2 (concatD [prt 0 d]) + PStr str -> prPrec i 2 (concatD [prt 0 str]) + PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")]) + PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")]) + PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts]) + PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts]) + PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt]) + PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt]) + PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")]) + PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt]) + PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt]) + + prtList es = case es of + [x] -> (concatD [prt 2 x]) + x:xs -> (concatD [prt 2 x , prt 0 xs]) + +instance Print PattAss where + prt i e = case e of + PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Label where + prt i e = case e of + LPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) + LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n]) + + +instance Print Sort where + prt i e = case e of + Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")]) + Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")]) + Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")]) + Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")]) + Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")]) + + +instance Print Bind where + prt i e = case e of + BPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) + BWild -> prPrec i 0 (concatD [doc (showString "_")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Decl where + prt i e = case e of + DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) + DExp exp -> prPrec i 0 (concatD [prt 4 exp]) + + +instance Print TupleComp where + prt i e = case e of + TComp exp -> prPrec i 0 (concatD [prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print PattTupleComp where + prt i e = case e of + PTComp patt -> prPrec i 0 (concatD [prt 0 patt]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Case where + prt i e = case e of + Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Equation where + prt i e = case e of + Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Altern where + prt i e = case e of + Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print DDecl where + prt i e = case e of + DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) + DDExp exp -> prPrec i 0 (concatD [prt 6 exp]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print OldGrammar where + prt i e = case e of + OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs]) + + +instance Print Include where + prt i e = case e of + NoIncl -> prPrec i 0 (concatD []) + Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames]) + + +instance Print FileName where + prt i e = case e of + FString str -> prPrec i 0 (concatD [prt 0 str]) + FPIdent pident -> prPrec i 0 (concatD [prt 0 pident]) + FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename]) + FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename]) + FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename]) + FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename]) + + prtList es = case es of + [x] -> (concatD [prt 0 x , doc (showString ";")]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + + diff --git a/src-3.0/GF/Devel/Compile/Refresh.hs b/src-3.0/GF/Devel/Compile/Refresh.hs new file mode 100644 index 000000000..1708761fc --- /dev/null +++ b/src-3.0/GF/Devel/Compile/Refresh.hs @@ -0,0 +1,118 @@ +---------------------------------------------------------------------- +-- | +-- Module : Refresh +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:27 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- make variable names unique by adding an integer index to each +----------------------------------------------------------------------------- + +module GF.Devel.Compile.Refresh ( + refreshModule, + refreshTerm, + refreshTermN + ) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad + + +-- for concrete and resource in grammar, before optimizing + +refreshModule :: Int -> SourceModule -> Err (SourceModule,Int) +refreshModule k (m,mo) = do + (mo',(_,k')) <- appSTM (termOpModule refresh mo) (initIdStateN k) + return ((m,mo'),k') + + +refreshTerm :: Term -> Err Term +refreshTerm = refreshTermN 0 + +refreshTermN :: Int -> Term -> Err Term +refreshTermN i e = liftM snd $ refreshTermKN i e + +refreshTermKN :: Int -> Term -> Err (Int,Term) +refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ + appSTM (refresh e) (initIdStateN i) + +refresh :: Term -> STM IdState Term +refresh e = case e of + + Vr x -> liftM Vr (lookVar x) + Abs x b -> liftM2 Abs (refVarPlus x) (refresh b) + + Prod x a b -> do + a' <- refresh a + x' <- refVarPlus x + b' <- refresh b + return $ Prod x' a' b' + + Let (x,(mt,a)) b -> do + a' <- refresh a + mt' <- case mt of + Just t -> refresh t >>= (return . Just) + _ -> return mt + x' <- refVar x + b' <- refresh b + return (Let (x',(mt',a')) b') + + R r -> liftM R $ refreshRecord r + + ExtR r s -> liftM2 ExtR (refresh r) (refresh s) + + T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc) + + _ -> composOp refresh e + +refreshCase :: (Patt,Term) -> STM IdState (Patt,Term) +refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t) + +refreshPatt p = case p of + PV x -> liftM PV (refVarPlus x) + PC c ps -> liftM (PC c) (mapM refreshPatt ps) + PP q c ps -> liftM (PP q c) (mapM refreshPatt ps) + PR r -> liftM PR (mapPairsM refreshPatt r) + PT t p' -> liftM2 PT (refresh t) (refreshPatt p') + + PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p') + + PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q') + PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q') + PRep p' -> liftM PRep (refreshPatt p') + PNeg p' -> liftM PNeg (refreshPatt p') + + _ -> return p + +refreshRecord r = case r of + [] -> return r + (x,(mt,a)):b -> do + a' <- refresh a + mt' <- case mt of + Just t -> refresh t >>= (return . Just) + _ -> return mt + b' <- refreshRecord b + return $ (x,(mt',a')) : b' + +refreshTInfo i = case i of + TTyped t -> liftM TTyped $ refresh t + TComp t -> liftM TComp $ refresh t + TWild t -> liftM TWild $ refresh t + _ -> return i + +-- for abstract syntax + +refreshEquation :: Equation -> Err ([Patt],Term) +refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where + refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t) + diff --git a/src-3.0/GF/Devel/Compile/Rename.hs b/src-3.0/GF/Devel/Compile/Rename.hs new file mode 100644 index 000000000..9ba704c19 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/Rename.hs @@ -0,0 +1,239 @@ +---------------------------------------------------------------------- +-- | +-- Module : Rename +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.19 $ +-- +-- AR 14\/5\/2003 +-- The top-level function 'renameGrammar' does several things: +-- +-- - extends each module symbol table by indirections to extended module +-- +-- - changes unqualified and as-qualified imports to absolutely qualified +-- +-- - goes through the definitions and resolves names +-- +----------------------------------------------------------------------------- + +module GF.Devel.Compile.Rename ( + renameModule + ) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.PrGF +import GF.Infra.Ident +import GF.Devel.Grammar.Lookup +import GF.Data.Operations + +import Control.Monad +import qualified Data.Map as Map +import Data.List (nub) +import Debug.Trace (trace) + +{- +-- | this gives top-level access to renaming term input in the cc command +renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term +renameSourceTerm g m t = do + mo <- lookupErr m (modules g) + status <- buildStatus g m mo + renameTerm status [] t +-} + +renameModule :: GF -> SourceModule -> Err SourceModule +renameModule gf sm@(name,mo) = case mtype mo of + MTInterface -> return sm + _ | not (isCompleteModule mo) -> return sm + _ -> errIn ("renaming module" +++ prt name) $ do + let gf1 = gf {gfmodules = Map.insert name mo (gfmodules gf)} + let rename = renameTerm (gf1,sm) [] + mo1 <- termOpModule rename mo + let mo2 = mo1 {mopens = nub [(i,i) | (_,i) <- mopens mo1]} + return (name,mo2) + +type RenameEnv = (GF,SourceModule) + +renameIdentTerm :: RenameEnv -> Term -> Err Term +renameIdentTerm (gf, (name,mo)) trm = case trm of + Vr i -> looks i + Con i -> looks i + Q m i -> getQualified m >>= look i + QC m i -> getQualified m >>= look i + _ -> return trm + where + looks i = do + let ts = nub [t | m <- pool, Ok t <- [look i m]] + case ts of + [t] -> return t + [] | elem i [IC "Int",IC "Float",IC "String"] -> ---- do this better + return (Q (IC "PredefAbs") i) + [] -> prtBad "identifier not found" i + t:_ -> + trace (unwords $ "WARNING":"identifier":prt i:"ambiguous:" : map prt ts) + (return t) +---- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts + look i m = do + ju <- lookupIdent gf m i + return $ case jform ju of + JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i + _ -> if isConstructor ju then QC m i else Q m i + pool = nub $ name : + maybe name id (interfaceName mo) : + IC "Predef" : + map fst (mextends mo) ++ + map snd (mopens mo) + getQualified m = case Map.lookup m qualifMap of + Just n -> return n + _ -> prtBad "unknown qualifier" m + qualifMap = Map.fromList $ + mopens mo ++ + concat [ops | (_,ops) <- minstances mo] ++ + [(m,m) | m <- pool] + ---- TODO: check uniqueness of these names + +renameTerm :: RenameEnv -> [Ident] -> Term -> Err Term +renameTerm env vars = ren vars where + ren vs trm = case trm of + Abs x b -> liftM (Abs x) (ren (x:vs) b) + Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) + Typed a b -> liftM2 Typed (ren vs a) (ren vs b) + Vr x + | elem x vs -> return trm + | otherwise -> renid trm + Con _ -> renid trm + Q _ _ -> renid trm + QC _ _ -> renid trm + Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs + T i cs -> do + i' <- case i of + TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source + _ -> return i + liftM (T i') $ mapM (renCase vs) cs + + Let (x,(m,a)) b -> do + m' <- case m of + Just ty -> liftM Just $ ren vs ty + _ -> return m + a' <- ren vs a + b' <- ren (x:vs) b + return $ Let (x,(m',a')) b' + + P t@(Vr r) l -- for constant t we know it is projection + | elem r vs -> return trm -- var proj first + | otherwise -> case renid (Q r (label2ident l)) of -- qualif second + Ok t -> return t + _ -> case liftM (flip P l) $ renid t of + Ok t -> return t -- const proj last + _ -> prtBad "unknown qualified constant" trm + + EPatt p -> do + (p',_) <- renpatt p + return $ EPatt p' + + _ -> composOp (ren vs) trm + + renid = renameIdentTerm env + renCase vs (p,t) = do + (p',vs') <- renpatt p + t' <- ren (vs' ++ vs) t + return (p',t') + renpatt = renamePattern env + +-- | vars not needed in env, since patterns always overshadow old vars +renamePattern :: RenameEnv -> Patt -> Err (Patt,[Ident]) +renamePattern env patt = case patt of + + PMacro c -> do + c' <- renid $ Vr c + case c' of + Q p d -> renp $ PM p d + _ -> prtBad "unresolved pattern" patt + + PC c ps -> do + c' <- renid $ Vr c + case c' of + QC p d -> renp $ PP p d ps + Q p d -> renp $ PP p d ps + _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs) + + PP p c ps -> do + + (p', c') <- case renid (QC p c) of + Ok (QC p' c') -> return (p',c') + _ -> return (p,c) --- temporarily, for bw compat + psvss <- mapM renp ps + let (ps',vs) = unzip psvss + return (PP p' c' ps', concat vs) + + PV x -> case renid (Vr x) of + Ok (QC m c) -> return (PP m c [],[]) + _ -> return (patt, [x]) + + PR r -> do + let (ls,ps) = unzip r + psvss <- mapM renp ps + let (ps',vs') = unzip psvss + return (PR (zip ls ps'), concat vs') + + PAlt p q -> do + (p',vs) <- renp p + (q',ws) <- renp q + return (PAlt p' q', vs ++ ws) + + PSeq p q -> do + (p',vs) <- renp p + (q',ws) <- renp q + return (PSeq p' q', vs ++ ws) + + PRep p -> do + (p',vs) <- renp p + return (PRep p', vs) + + PNeg p -> do + (p',vs) <- renp p + return (PNeg p', vs) + + PAs x p -> do + (p',vs) <- renp p + return (PAs x p', x:vs) + + _ -> return (patt,[]) + + where + renp = renamePattern env + renid = renameIdentTerm env + +renameParam :: RenameEnv -> (Ident, Context) -> Err (Ident, Context) +renameParam env (c,co) = do + co' <- renameContext env co + return (c,co') + +renameContext :: RenameEnv -> Context -> Err Context +renameContext b = renc [] where + renc vs cont = case cont of + (x,t) : xts + | isWildIdent x -> do + t' <- ren vs t + xts' <- renc vs xts + return $ (x,t') : xts' + | otherwise -> do + t' <- ren vs t + let vs' = x:vs + xts' <- renc vs' xts + return $ (x,t') : xts' + _ -> return cont + ren = renameTerm b + +-- | vars not needed in env, since patterns always overshadow old vars +renameEquation :: RenameEnv -> [Ident] -> Equation -> Err Equation +renameEquation b vs (ps,t) = do + (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps + t' <- renameTerm b (concat vs' ++ vs) t + return (ps',t') + diff --git a/src-3.0/GF/Devel/Compile/SourceToGF.hs b/src-3.0/GF/Devel/Compile/SourceToGF.hs new file mode 100644 index 000000000..a62179c18 --- /dev/null +++ b/src-3.0/GF/Devel/Compile/SourceToGF.hs @@ -0,0 +1,679 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/Compute.hs b/src-3.0/GF/Devel/Compute.hs new file mode 100644 index 000000000..a9081c28a --- /dev/null +++ b/src-3.0/GF/Devel/Compute.hs @@ -0,0 +1,455 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/GF.hs b/src-3.0/GF/Devel/GF.hs new file mode 100644 index 000000000..70fddcd67 --- /dev/null +++ b/src-3.0/GF/Devel/GF.hs @@ -0,0 +1,14 @@ +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-3.0/GF/Devel/GFC.hs b/src-3.0/GF/Devel/GFC.hs new file mode 100644 index 000000000..27e0e3ae2 --- /dev/null +++ b/src-3.0/GF/Devel/GFC.hs @@ -0,0 +1,67 @@ +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-3.0/GF/Devel/GFC/Main.hs b/src-3.0/GF/Devel/GFC/Main.hs new file mode 100644 index 000000000..d9ceb8e70 --- /dev/null +++ b/src-3.0/GF/Devel/GFC/Main.hs @@ -0,0 +1,28 @@ +module GF.Devel.GFC.Main where + +import GF.Devel.GFC.Options + +import System.Environment +import System.Exit +import System.IO + + +version = "X.X" + +main :: IO () +main = + do args <- getArgs + case parseOptions args of + Ok (opts, files) -> + case optMode opts of + Version -> putStrLn $ "GF, version " ++ version + Help -> putStr helpMessage + Compiler -> gfcMain opts files + Errors errs -> + do mapM_ (hPutStrLn stderr) errs + exitFailure + +gfcMain :: Options -> [FilePath] -> IO () +gfcMain opts files = return () + + diff --git a/src-3.0/GF/Devel/GFCCInterpreter.hs b/src-3.0/GF/Devel/GFCCInterpreter.hs new file mode 100644 index 000000000..b2b17dba7 --- /dev/null +++ b/src-3.0/GF/Devel/GFCCInterpreter.hs @@ -0,0 +1,28 @@ +module Main where + +import GF.Command.Interpreter +import GF.Command.Commands +import GF.GFCC.API +import System (getArgs) +import Data.Char (isDigit) + +-- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007 + +main :: IO () +main = do + file:_ <- getArgs + grammar <- file2grammar file + let env = CommandEnv grammar (allCommands grammar) + printHelp grammar + loop env + +loop :: CommandEnv -> IO () +loop env = do + s <- getLine + if s == "q" then return () else do + interpretCommandLine env s + loop env + +printHelp grammar = do + putStrLn $ "languages: " ++ unwords (languages grammar) + putStrLn $ "categories: " ++ unwords (categories grammar) diff --git a/src-3.0/GF/Devel/GFCCtoHaskell.hs b/src-3.0/GF/Devel/GFCCtoHaskell.hs new file mode 100644 index 000000000..aa3eebe58 --- /dev/null +++ b/src-3.0/GF/Devel/GFCCtoHaskell.hs @@ -0,0 +1,213 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/GFCCtoJS.hs b/src-3.0/GF/Devel/GFCCtoJS.hs new file mode 100644 index 000000000..c61ad08d5 --- /dev/null +++ b/src-3.0/GF/Devel/GFCCtoJS.hs @@ -0,0 +1,132 @@ +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-3.0/GF/Devel/GFI.hs b/src-3.0/GF/Devel/GFI.hs new file mode 100644 index 000000000..f59bd15e6 --- /dev/null +++ b/src-3.0/GF/Devel/GFI.hs @@ -0,0 +1,77 @@ +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-3.0/GF/Devel/GetGrammar.hs b/src-3.0/GF/Devel/GetGrammar.hs new file mode 100644 index 000000000..cdd275ace --- /dev/null +++ b/src-3.0/GF/Devel/GetGrammar.hs @@ -0,0 +1,54 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/Grammar/AppPredefined.hs b/src-3.0/GF/Devel/Grammar/AppPredefined.hs new file mode 100644 index 000000000..c8d2988fd --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/AppPredefined.hs @@ -0,0 +1,166 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/Grammar/Compute.hs b/src-3.0/GF/Devel/Grammar/Compute.hs new file mode 100644 index 000000000..5e465c160 --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/Compute.hs @@ -0,0 +1,380 @@ +---------------------------------------------------------------------- +-- | +-- Module : Compute +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/01 15:39:12 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.19 $ +-- +-- Computation of source terms. Used in compilation and in @cc@ command. +----------------------------------------------------------------------------- + +module GF.Devel.Grammar.Compute ( + computeTerm, + computeTermCont, + computeTermRec + ) where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.Lookup +import GF.Devel.Grammar.PrGF +import GF.Devel.Grammar.PatternMatch +import GF.Devel.Grammar.AppPredefined + +import GF.Infra.Ident +import GF.Infra.Option + +--import GF.Grammar.Refresh +--import GF.Grammar.Lockfield (isLockLabel) ---- + +import GF.Data.Str ---- +import GF.Data.Operations + +import Data.List (nub,intersperse) +import Control.Monad (liftM2, liftM) + +-- | computation of concrete syntax terms into normal form +-- used mainly for partial evaluation +computeTerm :: GF -> Term -> Err Term +computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t +computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t + +computeTermCont :: GF -> Substitution -> Term -> Err Term +computeTermCont = computeTermOpt False + +-- rec=True is used if it cannot be assumed that looked-up constants +-- have already been computed (mainly with -optimize=noexpand in .gfr) + +computeTermOpt :: Bool -> GF -> Substitution -> Term -> Err Term +computeTermOpt rec gr = comp where + + comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging + case t of + + Q (IC "Predef") _ -> return t + Q p c -> look p c + + -- if computed do nothing + ---- Computed t' -> return $ unComputed t' + + Vr x -> do + t' <- maybe (prtBad ("no value for variable") x) return $ lookup x g + case t' of + _ | t == t' -> return t + _ -> comp g t' + + Abs x b -> do + b' <- comp (ext x (Vr x) g) b + return $ Abs x b' + + Let (x,(_,a)) b -> do + a' <- comp g a + comp (ext x a' g) b + + Prod x a b -> do + a' <- comp g a + b' <- comp (ext x (Vr x) g) b + return $ Prod x a' b' + + -- beta-convert + App f a -> do + f' <- comp g f + a' <- comp g a + case (f',a') of + (Abs x b, FV as) -> + mapM (\c -> comp (ext x c g) b) as >>= return . variants + (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants + (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants + (Abs x b,_) -> comp (ext x a' g) b + (QC _ _,_) -> returnC $ App f' a' + + (S (T i cs) e,_) -> prawitz g i (flip App a') cs e + (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e + + _ -> do + (t',b) <- appPredefined (App f' a') + if b then return t' else comp g t' + + P t l -> do + t' <- comp g t + case t' of + FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants + R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ + lookup l $ reverse r + + ExtR a (R b) -> + case comp g (P (R b) l) of + Ok v -> return v + _ -> comp g (P a l) + +--- { - --- this is incorrect, since b can contain the proper value + ExtR (R a) b -> -- NOT POSSIBLE both a and b records! + case comp g (P (R a) l) of + Ok v -> return v + _ -> comp g (P b l) +--- - } --- + + + S (T i cs) e -> prawitz g i (flip P l) cs e + S (V i cs) e -> prawitzV g i (flip P l) cs e + + _ -> returnC $ P t' l + + PI t l i -> comp g $ P t l ----- + + S t@(T ti cc) v -> do + v' <- comp g v + case v' of + FV vs -> do + ts' <- mapM (comp g . S t) vs + return $ variants ts' + _ -> case ti of +{- + TComp _ -> do + case term2patt v' of + Ok p' -> case lookup p' cc of + Just u -> comp g u + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + _ -> do + t' <- comp g t + return $ S t' v' +-} + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + + + S t v -> do + + t' <- case t of +---- why not? ResFin.Agr "has no values" +---- T (TComp _) _ -> return t +---- V _ _ -> return t + _ -> comp g t + + v' <- comp g v + + case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants + _ -> case t' of + FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants + + T _ [(PV IW,c)] -> comp g c --- an optimization + T _ [(PT _ (PV IW),c)] -> comp g c + + T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization + T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c + + -- course-of-values table: look up by index, no pattern matching needed + V ptyp ts -> do + vs <- allParamValues gr ptyp + case lookup v' (zip vs [0 .. length vs - 1]) of + Just i -> comp g $ ts !! i +----- _ -> prtBad "selection" $ S t' v' -- debug + _ -> return $ S t' v' -- if v' is not canonical + + T (TComp _) cs -> do + case term2patt v' of + Ok p' -> case lookup p' cs of + Just u -> comp g u + _ -> return $ S t' v' -- if v' is not canonical + _ -> return $ S t' v' + + T _ cc -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + + S (T i cs) e -> prawitz g i (flip S v') cs e + S (V i cs) e -> prawitzV g i (flip S v') cs e + _ -> returnC $ S t' v' + + -- normalize away empty tokens + K "" -> return Empty + + -- glue if you can + Glue x0 y0 -> do + x <- comp g x0 + y <- comp g y0 + case (x,y) of + (FV ks,_) -> do + kys <- mapM (comp g . flip Glue y) ks + return $ variants kys + (_,FV ks) -> do + xks <- mapM (comp g . Glue x) ks + return $ variants xks + + (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e + (s, S (T i cs) e) -> prawitz g i (Glue s) cs e + (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e + (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e + (_,Empty) -> return x + (Empty,_) -> return y + (K a, K b) -> return $ K (a ++ b) + (_, Alts (d,vs)) -> do +---- (K a, Alts (d,vs)) -> do + let glx = Glue x + comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) + (Alts _, ka) -> checks [do + y' <- strsFromTerm ka +---- (Alts _, K a) -> checks [do + x' <- strsFromTerm x -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] +---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] + ,return $ Glue x y + ] + (C u v,_) -> comp g $ C u (Glue v y) + + _ -> do + mapM_ checkNoArgVars [x,y] + r <- composOp (comp g) t + returnC r + + Alts _ -> do + r <- composOp (comp g) t + returnC r + + -- remove empty + C a b -> do + a' <- comp g a + b' <- comp g b + case (a',b') of + (Alts _, K a) -> checks [do + as <- strsFromTerm a' -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] + , + return $ C a' b' + ] + (Empty,_) -> returnC b' + (_,Empty) -> returnC a' + _ -> returnC $ C a' b' + + -- reduce free variation as much as you can + FV ts -> mapM (comp g) ts >>= returnC . variants + + -- merge record extensions if you can + ExtR r s -> do + r' <- comp g r + s' <- comp g s + case (r',s') of + (R rs, R ss) -> plusRecord r' s' + (RecType rs, RecType ss) -> plusRecType r' s' + _ -> return $ ExtR r' s' + + -- case-expand tables + -- if already expanded, don't expand again + T i@(TComp ty) cs -> do + -- if there are no variables, don't even go inside + cs' <- if (null g) then return cs else mapPairsM (comp g) cs +---- return $ V ty (map snd cs') + return $ T i cs' + + T i cs -> do + pty0 <- errIn (prt t) $ getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs -> do + + cs' <- mapM (compBranchOpt g) cs ---- why is this needed?? + sts <- mapM (matchPattern cs') vs + ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts + ps <- mapM term2patt vs + let ps' = ps --- PT ptyp (head ps) : tail ps +---- return $ V ptyp ts -- to save space ---- why doesn't this work?? + return $ T (TComp ptyp) (zip ps' ts) + _ -> do + cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + + -- otherwise go ahead + _ -> composOp (comp g) t >>= returnC + + where + + look p c + | rec = lookupOperDef gr p c >>= comp [] + | otherwise = lookupOperDef gr p c + +{- + look p c = case lookupResDefKind gr p c of + Ok (t,_) | noExpand p || rec -> comp [] t + Ok (t,_) -> return t + Bad s -> raise s + + noExpand p = errVal False $ do + mo <- lookupModMod gr p + return $ case getOptVal (iOpts (flags mo)) useOptimizer of + Just "noexpand" -> True + _ -> False +-} + + ext x a g = (x,a):g + + returnC = return --- . computed + + variants ts = case nub ts of + [t] -> t + ts -> FV ts + + isCan v = case v of + Con _ -> True + QC _ _ -> True + App f a -> isCan f && isCan a + R rs -> all (isCan . snd . snd) rs + _ -> False + + compBranch g (p,v) = do + let g' = contP p ++ g + v' <- comp g' v + return (p,v') + + compBranchOpt g c@(p,v) = case contP p of + [] -> return c + _ -> err (const (return c)) return $ compBranch g c + + contP p = case p of + PV x -> [(x,Vr x)] + PC _ ps -> concatMap contP ps + PP _ _ ps -> concatMap contP ps + PT _ p -> contP p + PR rs -> concatMap (contP . snd) rs + + PAs x p -> (x,Vr x) : contP p + + PSeq p q -> concatMap contP [p,q] + PAlt p q -> concatMap contP [p,q] + PRep p -> contP p + PNeg p -> contP p + + _ -> [] + + prawitz g i f cs e = do + cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] + return $ S (T i cs') e + prawitzV g i f cs e = do + cs' <- mapM (comp g) [(f v) | v <- cs] + return $ S (V i cs') e + +-- | argument variables cannot be glued +checkNoArgVars :: Term -> Err Term +checkNoArgVars t = case t of + Vr (IA _) -> Bad $ glueErrorMsg $ prt t + Vr (IAV _) -> Bad $ glueErrorMsg $ prt t + _ -> composOp checkNoArgVars t + +glueErrorMsg s = + "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ + "Use Prelude.bind instead." diff --git a/src-3.0/GF/Devel/Grammar/Construct.hs b/src-3.0/GF/Devel/Grammar/Construct.hs new file mode 100644 index 000000000..5b4215843 --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/Construct.hs @@ -0,0 +1,221 @@ +module GF.Devel.Grammar.Construct where + +import GF.Devel.Grammar.Grammar +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad +import Data.Map +import Debug.Trace (trace) + +------------------ +-- abstractions on Grammar, constructing objects +------------------ + +-- abstractions on GF + +emptyGF :: GF +emptyGF = GF Nothing [] empty empty + +type SourceModule = (Ident,Module) + +listModules :: GF -> [SourceModule] +listModules = assocs.gfmodules + +addModule :: Ident -> Module -> GF -> GF +addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} + +gfModules :: [(Ident,Module)] -> GF +gfModules ms = emptyGF {gfmodules = fromList ms} + +-- abstractions on Module + +emptyModule :: Module +emptyModule = Module MTGrammar True [] [] [] [] empty empty + +isCompleteModule :: Module -> Bool +isCompleteModule = miscomplete + +isInterface :: Module -> Bool +isInterface m = case mtype m of + MTInterface -> True + MTAbstract -> True + _ -> False + +interfaceName :: Module -> Maybe Ident +interfaceName mo = case mtype mo of + MTInstance i -> return i + MTConcrete i -> return i + _ -> Nothing + +listJudgements :: Module -> [(Ident,Judgement)] +listJudgements = assocs . mjments + +isInherited :: MInclude -> Ident -> Bool +isInherited mi i = case mi of + MIExcept is -> notElem i is + MIOnly is -> elem i is + _ -> True + +-- abstractions on Judgement + +isConstructor :: Judgement -> Bool +isConstructor j = jdef j == EData + +isLink :: Judgement -> Bool +isLink j = jform j == JLink + +-- constructing judgements from parse tree + +emptyJudgement :: JudgementForm -> Judgement +emptyJudgement form = Judgement form meta meta meta (identC "#") 0 where + meta = Meta 0 + +addJType :: Type -> Judgement -> Judgement +addJType tr ju = ju {jtype = tr} + +addJDef :: Term -> Judgement -> Judgement +addJDef tr ju = ju {jdef = tr} + +addJPrintname :: Term -> Judgement -> Judgement +addJPrintname tr ju = ju {jprintname = tr} + +linkInherited :: Bool -> Ident -> Judgement +linkInherited can mo = (emptyJudgement JLink){ + jlink = mo, + jdef = if can then EData else Meta 0 + } + +absCat :: Context -> Judgement +absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) + +absFun :: Type -> Judgement +absFun ty = addJType ty (emptyJudgement JFun) + +cncCat :: Type -> Judgement +cncCat ty = addJType ty (emptyJudgement JLincat) + +cncFun :: Term -> Judgement +cncFun tr = addJDef tr (emptyJudgement JLin) + +resOperType :: Type -> Judgement +resOperType ty = addJType ty (emptyJudgement JOper) + +resOperDef :: Term -> Judgement +resOperDef tr = addJDef tr (emptyJudgement JOper) + +resOper :: Type -> Term -> Judgement +resOper ty tr = addJDef tr (resOperType ty) + +resOverload :: [(Type,Term)] -> Judgement +resOverload tts = resOperDef (Overload tts) + +-- param p = ci gi is encoded as p : ((ci : gi) -> p) -> Type +-- we use EData instead of p to make circularity check easier +resParam :: Ident -> [(Ident,Context)] -> Judgement +resParam p cos = addJDef (EParam (Con p) cos) (addJType typePType (emptyJudgement JParam)) + +-- to enable constructor type lookup: +-- create an oper for each constructor p = c g, as c : g -> p = EData +paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)] +paramConstructors p cs = [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs] + +-- unifying contents of judgements + +---- used in SourceToGF; make error-free and informative +unifyJudgements j k = case unifyJudgement j k of + Ok l -> l + Bad s -> error s + +unifyJudgement :: Judgement -> Judgement -> Err Judgement +unifyJudgement old new = do + testErr (jform old == jform new) "different judment forms" + [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] + return $ old{jtype = jty, jdef = jde, jprintname = jpri} + where + unifyField field = unifyTerm (field old) (field new) + unifyTerm oterm nterm = case (oterm,nterm) of + (Meta _,t) -> return t + (t,Meta _) -> return t + _ -> do + if (nterm /= oterm) + then (trace (unwords ["illegal update of",show oterm,"to",show nterm]) + (return ())) + else return () ---- to recover from spurious qualification conflicts +---- testErr (nterm == oterm) +---- (unwords ["illegal update of",prt oterm,"to",prt nterm]) + return nterm + +updateJudgement :: Ident -> Ident -> Judgement -> GF -> Err GF +updateJudgement m c ju gf = do + mo <- maybe (Bad (show m)) return $ Data.Map.lookup m $ gfmodules gf + let mo' = mo {mjments = insert c ju (mjments mo)} + return $ gf {gfmodules = insert m mo' (gfmodules gf)} + +-- abstractions on Term + +type Cat = QIdent +type Fun = QIdent +type QIdent = (Ident,Ident) + +-- | branches à la Alfa +newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) +type Con = Ident --- + +varLabel :: Int -> Label +varLabel = LVar + +wildPatt :: Patt +wildPatt = PW + +type Trm = Term + +mkProd :: Context -> Type -> Type +mkProd = flip (foldr (uncurry Prod)) + +-- type constants + +typeType :: Type +typeType = Sort "Type" + +typePType :: Type +typePType = Sort "PType" + +typeStr :: Type +typeStr = Sort "Str" + +typeTok :: Type ---- deprecated +typeTok = Sort "Tok" + +cPredef :: Ident +cPredef = identC "Predef" + +cPredefAbs :: Ident +cPredefAbs = identC "PredefAbs" + +typeString, typeFloat, typeInt :: Term +typeInts :: Integer -> Term + +typeString = constPredefRes "String" +typeInt = constPredefRes "Int" +typeFloat = constPredefRes "Float" +typeInts i = App (constPredefRes "Ints") (EInt i) + +isTypeInts :: Term -> Bool +isTypeInts ty = case ty of + App c _ -> c == constPredefRes "Ints" + _ -> False + +cnPredef = constPredefRes + +constPredefRes :: String -> Term +constPredefRes s = Q (IC "Predef") (identC s) + +isPredefConstant :: Term -> Bool +isPredefConstant t = case t of + Q (IC "Predef") _ -> True + Q (IC "PredefAbs") _ -> True + _ -> False + + diff --git a/src-3.0/GF/Devel/Grammar/GFtoSource.hs b/src-3.0/GF/Devel/Grammar/GFtoSource.hs new file mode 100644 index 000000000..292f5b826 --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/GFtoSource.hs @@ -0,0 +1,223 @@ +module GF.Devel.Grammar.GFtoSource ( + trGrammar, + trModule, + trAnyDef, + trLabel, + trt, + tri, + trp + ) where + + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros (contextOfType) +import qualified GF.Devel.Compile.AbsGF as P +import GF.Infra.Ident + +import GF.Data.Operations + +import qualified Data.Map as Map + +-- From internal source syntax to BNFC-generated (used for printing). +-- | AR 13\/5\/2003 +-- +-- translate internal to parsable and printable source + +trGrammar :: GF -> P.Grammar +trGrammar = P.Gr . map trModule . listModules -- no includes + +trModule :: (Ident,Module) -> P.ModDef +trModule (i,mo) = P.MModule compl typ body where + compl = case isCompleteModule mo of + False -> P.CMIncompl + _ -> P.CMCompl + i' = tri i + typ = case mtype mo of + MTGrammar -> P.MGrammar i' + MTAbstract -> P.MAbstract i' + MTConcrete a -> P.MConcrete i' (tri a) + MTInterface -> P.MInterface i' + MTInstance a -> P.MInstance i' (tri a) + body = P.MBody + (trExtends (mextends mo)) + (mkOpens (map trOpen (mopens mo))) + (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++ + map trFlag (Map.assocs (mflags mo))) + +trExtends :: [(Ident,MInclude)] -> P.Extend +trExtends [] = P.NoExt +trExtends es = (P.Ext $ map tre es) where + tre (i,c) = case c of + MIAll -> P.IAll (tri i) + MIOnly is -> P.ISome (tri i) (map tri is) + MIExcept is -> P.IMinus (tri i) (map tri is) + +trOpen :: (Ident,Ident) -> P.Open +trOpen (i,j) = P.OQual (tri i) (tri j) + +mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds + +trAnyDef :: (Ident,Judgement) -> [P.TopDef] +trAnyDef (i,ju) = let + i' = mkName i + i0 = tri i + in case jform ju of + JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]] + JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]] + ---- ++ case pt of + ---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] + ---- _ -> [] + ---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]] + JParam -> [P.DefPar [ + P.ParDefDir i0 [ + P.ParConstr (tri c) (map trDecl co) | let EParam _ cos = jdef ju, (c,co) <- cos] + ]] + JOper -> case jdef ju of + Overload tysts -> + [P.DefOper [P.DDef [i'] ( + P.EApp (P.EPIdent $ ppIdent "overload") + (P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]] + tr -> [P.DefOper [trDef i (jtype ju) tr]] + JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]] + ---- CncCat pty ptr ppr -> + ---- [P.DefLindef [trDef i' pty ptr]] + ---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] + JLin -> + [P.DefLin [trDef i (Meta 0) (jdef ju)]] + ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] + JLink -> [] + +trDef :: Ident -> Type -> Term -> P.Def +trDef i pty ptr = case (pty,ptr) of + (Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) --- + (_, Meta _) -> P.DDecl [mkName i] (trPerh pty) + (Meta _, _) -> P.DDef [mkName i] (trPerh ptr) + (_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr) + +trPerh p = case p of + Meta _ -> P.EMeta + _ -> trt p + +trFlag :: (Ident,String) -> P.TopDef +trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)] + +trt :: Term -> P.Exp +trt trm = case trm of + Vr s -> P.EPIdent $ tri s +---- Cn s -> P.ECons $ tri s + Con s -> P.EConstr $ tri s + Sort s -> P.ESort $ case s of + "Type" -> P.Sort_Type + "PType" -> P.Sort_PType + "Tok" -> P.Sort_Tok + "Str" -> P.Sort_Str + "Strs" -> P.Sort_Strs + _ -> error $ "not yet sort " +++ show trm ---- + + App c a -> P.EApp (trt c) (trt a) + Abs x b -> P.EAbstr [trb x] (trt b) + Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts] + Meta m -> P.EMeta + Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b) + Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b) + + Example t s -> P.EExample (trt t) s + R [] -> P.ETuple [] --- to get correct parsing when read back + R r -> P.ERecord $ map trAssign r + RecType r -> P.ERecord $ map trLabelling r + ExtR x y -> P.EExtend (trt x) (trt y) + P t l -> P.EProj (trt t) (trLabel l) + PI t l _ -> P.EProj (trt t) (trLabel l) + Q t l -> P.EQCons (tri t) (tri l) + QC t l -> P.EQConstr (tri t) (tri l) + T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc) + T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc) + T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc) + T _ cc -> P.ETable (map trCase cc) + V ty cc -> P.EVTable (trt ty) (map trt cc) + + Typed tr ty -> P.ETyped (trt tr) (trt ty) + Table x v -> P.ETType (trt x) (trt v) + S f x -> P.ESelect (trt f) (trt x) + Let (x,(ma,b)) t -> + P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t) + where + b' = trt b + x' = [tri x] + Empty -> P.EEmpty + K [] -> P.EEmpty + K a -> P.EString a + C a b -> P.EConcat (trt a) (trt b) + + EInt i -> P.EInt i + EFloat i -> P.EFloat i + + EPatt p -> P.EPatt (trp p) + EPattType t -> P.EPattType (trt t) + + Glue a b -> P.EGlue (trt a) (trt b) + Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt] + FV ts -> P.EVariants $ map trt ts + EData -> P.EData + EParam t _ -> trt t + + _ -> error $ "not yet" +++ show trm ---- + +trp :: Patt -> P.Patt +trp p = case p of + PChar -> P.PChar + PChars s -> P.PChars s + PM m c -> P.PM (tri m) (tri c) + PW -> P.PW + PV s | isWildIdent s -> P.PW + PV s -> P.PV $ tri s + PC c [] -> P.PCon $ tri c + PC c a -> P.PC (tri c) (map trp a) + PP p c [] -> P.PQ (tri p) (tri c) + PP p c a -> P.PQC (tri p) (tri c) (map trp a) + PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r] + PString s -> P.PStr s + PInt i -> P.PInt i + PFloat i -> P.PFloat i + PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t) + + PAs x p -> P.PAs (tri x) (trp p) + + PAlt p q -> P.PDisj (trp p) (trp q) + PSeq p q -> P.PSeq (trp p) (trp q) + PRep p -> P.PRep (trp p) + PNeg p -> P.PNeg (trp p) + + +trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty + where + t' = trt t + x = [trLabelIdent lab] + +trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty) + +trCase (patt, trm) = P.Case (trp patt) (trt trm) +trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm) + +trDecl (x,ty) = P.DDDec [trb x] (trt ty) + +tri :: Ident -> P.PIdent +tri i = ppIdent (prIdent i) + +ppIdent i = P.PIdent ((0,0),i) + +trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i) + +trLabel :: Label -> P.Label +trLabel i = case i of + LIdent s -> P.LPIdent $ ppIdent s + LVar i -> P.LVar $ toInteger i + +trLabelIdent i = ppIdent $ case i of + LIdent s -> s + LVar i -> "v" ++ show i --- should not happen + +mkName :: Ident -> P.Name +mkName = P.PIdentName . tri + diff --git a/src-3.0/GF/Devel/Grammar/Grammar.hs b/src-3.0/GF/Devel/Grammar/Grammar.hs new file mode 100644 index 000000000..df5a3907e --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/Grammar.hs @@ -0,0 +1,172 @@ +module GF.Devel.Grammar.Grammar where + +import GF.Infra.Ident + +import GF.Data.Operations + +import Data.Map + + +------------------ +-- definitions -- +------------------ + +data GF = GF { + gfabsname :: Maybe Ident , + gfcncnames :: [Ident] , + gflags :: Map Ident String , -- value of a global flag + gfmodules :: Map Ident Module + } + +data Module = Module { + mtype :: ModuleType, + miscomplete :: Bool, + minterfaces :: [(Ident,Ident)], -- non-empty for functors + minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for inst'ions + mextends :: [(Ident,MInclude)], + mopens :: [(Ident,Ident)], -- used name, original name + mflags :: Map Ident String, + mjments :: Map Ident Judgement + } + +data ModuleType = + MTAbstract + | MTConcrete Ident + | MTInterface + | MTInstance Ident + | MTGrammar + deriving Eq + +data MInclude = + MIAll + | MIExcept [Ident] + | MIOnly [Ident] + +type Indirection = (Ident,Bool) -- module of origin, whether canonical + +data Judgement = Judgement { + jform :: JudgementForm, -- cat fun lincat lin oper param + jtype :: Type, -- context type lincat - type PType + jdef :: Term, -- lindef def lindef lin def constrs + jprintname :: Term, -- - - prname prname - - + jlink :: Ident, -- if inherited, the supermodule name, else # + jposition :: Int -- line number where def begins + } + deriving Show + +data JudgementForm = + JCat + | JFun + | JLincat + | JLin + | JOper + | JParam + | JLink + deriving (Eq,Show) + +type Type = Term + +data Term = + Vr Ident -- ^ variable + | Con Ident -- ^ constructor + | EData -- ^ to mark in definition that a fun is a constructor + | Sort String -- ^ predefined type + | EInt Integer -- ^ integer literal + | EFloat Double -- ^ floating point literal + | K String -- ^ string literal or token: @\"foo\"@ + | Empty -- ^ the empty string @[]@ + + | App Term Term -- ^ application: @f a@ + | Abs Ident Term -- ^ abstraction: @\x -> b@ + | Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0) + | Prod Ident Term Term -- ^ function type: @(x : A) -> B@ + | Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@ + -- only used in internal representation + | Typed Term Term -- ^ type-annotated term +-- +-- /below this, the constructors are only for concrete syntax/ + | Example Term String -- ^ example-based term: @in M.C "foo" + | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@ + | R [Assign] -- ^ record: @{ p = a ; ...}@ + | P Term Label -- ^ projection: @r.p@ + | PI Term Label Int -- ^ index-annotated projection + | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms) + + | Table Term Term -- ^ table type: @P => A@ + | T TInfo [Case] -- ^ table: @table {p => c ; ...}@ + | V Type [Term] -- ^ course of values: @table T [c1 ; ... ; cn]@ + | S Term Term -- ^ selection: @t ! p@ + | Val Type Int -- ^ parameter value number: @T # i# + + | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ + + | Q Ident Ident -- ^ qualified constant from a module + | QC Ident Ident -- ^ qualified constructor from a module + + | C Term Term -- ^ concatenation: @s ++ t@ + | Glue Term Term -- ^ agglutination: @s + t@ + + | EPatt Patt + | EPattType Term + + | EParam Term [(Ident,Context)] -- to encode parameter constructor sets + + | FV [Term] -- ^ free variation: @variants { s ; ... }@ + + | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@ + + | Overload [(Type,Term)] + + deriving (Read, Show, Eq, Ord) + +data Patt = + PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ + | PP Ident Ident [Patt] -- ^ qualified constr patt: @P.C p1 ... pn@ @P.C@ + | PV Ident -- ^ variable pattern: @x@ + | PW -- ^ wild card pattern: @_@ + | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ + | PString String -- ^ string literal pattern: @\"foo\"@ + | PInt Integer -- ^ integer literal pattern: @12@ + | PFloat Double -- ^ float literal pattern: @1.2@ + | PT Type Patt -- ^ type-annotated pattern + | PAs Ident Patt -- ^ as-pattern: x@p + + -- regular expression patterns + | PNeg Patt -- ^ negated pattern: -p + | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 + | PSeq Patt Patt -- ^ sequence of token parts: p + q + | PRep Patt -- ^ repetition of token part: p* + | PChar -- ^ string of length one: ? + | PChars String -- ^ list of characters: ["aeiou"] + + | PMacro Ident -- #p + | PM Ident Ident -- #m.p + + deriving (Read, Show, Eq, Ord) + +-- | to guide computation and type checking of tables +data TInfo = + TRaw -- ^ received from parser; can be anything + | TTyped Type -- ^ type annotated, but can be anything + | TComp Type -- ^ expanded + | TWild Type -- ^ just one wild card pattern, no need to expand + deriving (Read, Show, Eq, Ord) + +-- | record label +data Label = + LIdent String + | LVar Int + deriving (Read, Show, Eq, Ord) + +type MetaSymb = Int + +type Decl = (Ident,Term) -- (x:A) (_:A) A +type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) +type Substitution = [(Ident, Term)] +type Equation = ([Patt],Term) + +type Labelling = (Label, Term) +type Assign = (Label, (Maybe Type, Term)) +type Case = (Patt, Term) +type LocalDef = (Ident, (Maybe Type, Term)) + diff --git a/src-3.0/GF/Devel/Grammar/Lookup.hs b/src-3.0/GF/Devel/Grammar/Lookup.hs new file mode 100644 index 000000000..689996760 --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/Lookup.hs @@ -0,0 +1,168 @@ +module GF.Devel.Grammar.Lookup where + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.PrGF +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad (liftM) +import Data.Map +import Data.List (sortBy) ---- + +-- look up fields for a constant in a grammar + +lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a +lookupJField field gf m c = do + j <- lookupJudgement gf m c + return $ field j + +lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm +lookupJForm = lookupJField jform + +-- the following don't (need to) check that the jment form is adequate + +lookupCatContext :: GF -> Ident -> Ident -> Err Context +lookupCatContext gf m c = do + ty <- lookupJField jtype gf m c + return $ contextOfType ty + +lookupFunType :: GF -> Ident -> Ident -> Err Term +lookupFunType = lookupJField jtype + +lookupLin :: GF -> Ident -> Ident -> Err Term +lookupLin = lookupJField jdef + +lookupLincat :: GF -> Ident -> Ident -> Err Term +lookupLincat = lookupJField jtype + +lookupOperType :: GF -> Ident -> Ident -> Err Term +lookupOperType gr m c = do + ju <- lookupJudgement gr m c + case jform ju of + JParam -> return typePType + _ -> case jtype ju of + Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c) + ty -> return ty +---- can't be just lookupJField jtype + +lookupOperDef :: GF -> Ident -> Ident -> Err Term +lookupOperDef = lookupJField jdef + +lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))] +lookupOverload gr m c = do + tr <- lookupJField jdef gr m c + case tr of + Overload tysts -> return + [(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty] + _ -> Bad $ prt c +++ "is not an overloaded operation" + +lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] +lookupParams gf m c = do + EParam _ ty <- lookupJField jdef gf m c + return ty + +lookupParamConstructor :: GF -> Ident -> Ident -> Err Type +lookupParamConstructor = lookupJField jtype + +lookupParamValues :: GF -> Ident -> Ident -> Err [Term] +lookupParamValues gf m c = do + ps <- lookupParams gf m c + liftM concat $ mapM mkPar ps + where + mkPar (f,co) = do + vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co + return $ lmap (mkApp (QC m f)) vs + +lookupFlags :: GF -> Ident -> [(Ident,String)] +lookupFlags gf m = errVal [] $ do + mo <- lookupModule gf m + return $ toList $ mflags mo + +allParamValues :: GF -> Type -> Err [Term] +allParamValues cnc ptyp = case ptyp of + App (Q (IC "Predef") (IC "Ints")) (EInt n) -> + return [EInt i | i <- [0..n]] + QC p c -> lookupParamValues cnc p c + Q p c -> lookupParamValues cnc p c ---- + + RecType r -> do + let (ls,tys) = unzip $ sortByFst r + tss <- mapM allPV tys + return [R (zipAssign ls ts) | ts <- combinations tss] + _ -> prtBad "cannot find parameter values for" ptyp + where + allPV = allParamValues cnc + -- to normalize records and record types + sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) + +abstractOfConcrete :: GF -> Ident -> Err Ident +abstractOfConcrete gf m = do + mo <- lookupModule gf m + case mtype mo of + MTConcrete a -> return a + MTInstance a -> return a + MTGrammar -> return m + _ -> prtBad "not concrete module" m + +allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)] +allOrigJudgements gf m = errVal [] $ do + mo <- lookupModule gf m + return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink] + +allConcretes :: GF -> Ident -> [Ident] +allConcretes gf m = + [c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m] + +-- | select just those modules that a given one depends on, including itself +partOfGrammar :: GF -> (Ident,Module) -> GF +partOfGrammar gr (i,mo) = gr { + gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor] + } + where + mos = toList $ gfmodules gr + modsFor = i : allDepsModule gr mo + +allDepsModule :: GF -> Module -> [Ident] +allDepsModule gr m = iterFix add os0 where + os0 = depPathModule m + add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n] + mods = toList $ gfmodules gr + +-- | initial dependency list +depPathModule :: Module -> [Ident] +depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where + fors = case mtype mo of + MTConcrete i -> [i] + MTInstance i -> [i] + _ -> [] + +-- infrastructure for lookup + +lookupModule :: GF -> Ident -> Err Module +lookupModule gf m = do + maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf) + +-- this finds the immediate definition, which can be a link +lookupIdent :: GF -> Ident -> Ident -> Err Judgement +lookupIdent gf m c = do + mo <- lookupModule gf m + maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo) + +-- this follows the link +lookupJudgement :: GF -> Ident -> Ident -> Err Judgement +lookupJudgement gf m c = do + ju <- lookupIdent gf m c + case jform ju of + JLink -> lookupJudgement gf (jlink ju) c + _ -> return ju + +mlookup = Data.Map.lookup + +raiseIdent msg i = raise (msg +++ prIdent i) + +lmap = Prelude.map +llookup = Prelude.lookup + diff --git a/src-3.0/GF/Devel/Grammar/Macros.hs b/src-3.0/GF/Devel/Grammar/Macros.hs new file mode 100644 index 000000000..1a7a3582c --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/Macros.hs @@ -0,0 +1,434 @@ +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-3.0/GF/Devel/Grammar/PatternMatch.hs b/src-3.0/GF/Devel/Grammar/PatternMatch.hs new file mode 100644 index 000000000..ec64d7802 --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/PatternMatch.hs @@ -0,0 +1,146 @@ +---------------------------------------------------------------------- +-- | +-- Module : PatternMatch +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/12 12:38:29 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.7 $ +-- +-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 +----------------------------------------------------------------------------- + +module GF.Devel.Grammar.PatternMatch (matchPattern, + testOvershadow, + findMatch + ) where + + +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Macros +import GF.Devel.Grammar.PrGF +import GF.Infra.Ident + +import GF.Data.Operations + +import Data.List +import Control.Monad + + +matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) +matchPattern pts term = + if not (isInConstantForm term) + then prtBad "variables occur in" term + else + errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $ + findMatch [([p],t) | (p,t) <- pts] [term] + +testOvershadow :: [Patt] -> [Term] -> Err [Patt] +testOvershadow pts vs = do + let numpts = zip pts [0..] + let cases = [(p,EInt i) | (p,i) <- numpts] + ts <- mapM (liftM fst . matchPattern cases) vs + return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] + +findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) +findMatch cases terms = case cases of + [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + (patts,_):_ | length patts /= length terms -> + Bad ("wrong number of args for patterns :" +++ + unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) + (patts,val):cc -> case mapM tryMatch (zip patts terms) of + Ok substs -> return (val, concat substs) + _ -> findMatch cc terms + +tryMatch :: (Patt, Term) -> Err [(Ident, Term)] +tryMatch (p,t) = do + let t' = termForm t + trym p t' + where + isInConstantFormt = True -- tested already + trym p t' = + case (p,t') of + (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] + (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard + (PV x, _) | isInConstantFormt -> return [(x,t)] + (PString s, ([],K i,[])) | s==i -> return [] + (PInt s, ([],EInt i,[])) | s==i -> return [] + (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? + (PC p pp, ([], Con f, tt)) | + p `eqStrIdent` f && length pp == length tt -> + do matches <- mapM tryMatch (zip pp tt) + return (concat matches) + + (PP q p pp, ([], QC r f, tt)) | + -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 + p `eqStrIdent` f && length pp == length tt -> + do matches <- mapM tryMatch (zip pp tt) + return (concat matches) + ---- hack for AppPredef bug + (PP q p pp, ([], Q r f, tt)) | + -- q `eqStrIdent` r && --- + p `eqStrIdent` f && length pp == length tt -> + do matches <- mapM tryMatch (zip pp tt) + return (concat matches) + + (PR r, ([],R r',[])) | + all (`elem` map fst r') (map fst r) -> + do matches <- mapM tryMatch + [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] + return (concat matches) + (PT _ p',_) -> trym p' t' + +-- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do + + (PAs x p',_) -> do + subst <- trym p' t' + return $ (x,t) : subst + + (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t'] + + (PNeg p',_) -> case tryMatch (p',t) of + Bad _ -> return [] + _ -> prtBad "no match with negative pattern" p + + (PSeq p1 p2, ([],K s, [])) -> do + let cuts = [splitAt n s | n <- [0 .. length s]] + matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts] + return (concat matches) + + (PRep p1, ([],K s, [])) -> checks [ + trym (foldr (const (PSeq p1)) (PString "") + [1..n]) t' | n <- [0 .. length s] + ] >> + return [] + + (PChar, ([],K [_], [])) -> return [] + (PChars cs, ([],K [c], [])) | elem c cs -> return [] + + _ -> prtBad "no match in case expr for" t + +eqStrIdent = (==) ---- + +isInConstantForm :: Term -> Bool +isInConstantForm trm = case trm of + Con _ -> True + Q _ _ -> True + QC _ _ -> True + Abs _ _ -> True + App c a -> isInConstantForm c && isInConstantForm a + R r -> all (isInConstantForm . snd . snd) r + K _ -> True + Empty -> True + EInt _ -> True + _ -> False ---- isInArgVarForm trm + +varsOfPatt :: Patt -> [Ident] +varsOfPatt p = case p of + PV x -> [x | not (isWildIdent x)] + PC _ ps -> concat $ map varsOfPatt ps + PP _ _ ps -> concat $ map varsOfPatt ps + PR r -> concat $ map (varsOfPatt . snd) r + PT _ q -> varsOfPatt q + _ -> [] + diff --git a/src-3.0/GF/Devel/Grammar/PrGF.hs b/src-3.0/GF/Devel/Grammar/PrGF.hs new file mode 100644 index 000000000..221a0ac61 --- /dev/null +++ b/src-3.0/GF/Devel/Grammar/PrGF.hs @@ -0,0 +1,246 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/GrammarToGFCC.hs b/src-3.0/GF/Devel/GrammarToGFCC.hs new file mode 100644 index 000000000..2c1bbc169 --- /dev/null +++ b/src-3.0/GF/Devel/GrammarToGFCC.hs @@ -0,0 +1,545 @@ +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-3.0/GF/Devel/Infra/ReadFiles.hs b/src-3.0/GF/Devel/Infra/ReadFiles.hs new file mode 100644 index 000000000..dd8cbe5a9 --- /dev/null +++ b/src-3.0/GF/Devel/Infra/ReadFiles.hs @@ -0,0 +1,348 @@ +---------------------------------------------------------------------- +-- | +-- Module : ReadFiles +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.26 $ +-- +-- Decide what files to read as function of dependencies and time stamps. +-- +-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 +-- +-- to find all files that have to be read, put them in dependency order, and +-- decide which files need recompilation. Name @file.gf@ is returned for them, +-- and @file.gfo@ otherwise. +----------------------------------------------------------------------------- + +module GF.Devel.Infra.ReadFiles (-- * Heading 1 + getAllFiles,fixNewlines,ModName,getOptionsFromFile, + -- * Heading 2 + gfoFile,gfFile,isGFO,resModName,isOldFile + ) where + +import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime) + +import GF.Infra.Option +import GF.Data.Operations +import GF.Devel.UseIO + +import System +import Data.Char +import Control.Monad +import Data.List +import System.Directory + +type ModName = String +type ModEnv = [(ModName,ModTime)] + +getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] +getAllFiles opts ps env file = do + + -- read module headers from all files recursively + ds0 <- getImports ps file + let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] + if oElem beVerbose opts + then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) + else return () + -- get a topological sorting of files: returns file names --- deletes paths + ds1 <- ioeErr $ either + return + (\ms -> Bad $ "circular modules" +++ + unwords (map show (head ms))) $ topoTest $ map fst ds + + -- associate each file name with its path --- more optimal: save paths in ds1 + let paths = [(f,p) | ((f,_),p) <- ds] + let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] + if oElem fromSource opts + then return [gfFile (p f) | (p,f) <- pds1] + else do + + + ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 + + let ds4 = needCompile opts (map fst ds0) ds2 + return ds4 + +-- to decide whether to read gf or gfo, or if in env; returns full file path + +data CompStatus = + CSComp -- compile: read gf + | CSRead -- read gfo + | CSEnv -- gfo is in env + | CSEnvR -- also gfr is in env + | CSDont -- don't read at all + | CSRes -- read gfr + deriving (Eq,Show) + +-- for gfo, we also return ModTime to cope with earlier compilation of libs + +selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> + IO (ModName,(InitPath,(CompStatus,Maybe ModTime))) + +selectFormat opts env (p,f) = do + let pf = p f + let mtenv = lookup f env -- Nothing if f is not in env + let rtenv = lookup (resModName f) env + let fromComp = oElem isCompiled opts -- i -gfo + mtgfc <- getModTime $ gfoFile pf + mtgf <- getModTime $ gfFile pf + let stat = case (rtenv,mtenv,mtgfc,mtgf) of + (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) + (_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc) + (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv) + (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv) + (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> (CSRead,Just tgfc) + (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist + (_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist + _ -> (CSComp,Nothing) + return $ (f, (p,stat)) + +needCompile :: Options -> + [ModuleHeader] -> + [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath] +needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where + + deps = [(snd m,map fst ms) | (m,ms) <- headers] + typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers] + uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m] + stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0 + + allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where + add os = [m | o <- os, Just n <- [lookup o deps],m <- n] + + -- only treat reused, interface, or instantiation if needed + sfiles = sfiles0 ---- map relevant sfiles0 + relevant fp@(f,(p,(st,_))) = + let us = uses f + isUsed = not (null us) + in + if not (isUsed && all noComp us) then + fp else + if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource] + || + (isUsed && all isAux us)) then + (f,(p,(CSDont,Nothing))) else + fp + + isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd + noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst + + -- mark as to be compiled those whose gfo is earlier than a deeper gfo + sfiles1 = map compTimes sfiles + compTimes fp@(f,(p,(_, Just t))) = + if any (> t) [t' | Just fs <- [lookup f deps], + f0 <- fs, + Just (_,(_,Just t')) <- [lookup f0 sfiles]] + then (f,(p,(CSComp, Nothing))) + else fp + compTimes fp = fp + + -- start with the changed files themselves; returns [ModName] + changed = [f | (f,(_,(CSComp,_))) <- sfiles1] + + -- add other files that depend on some changed file; returns [ModName] + iter np = let new = [f | (f,fs) <- deps, + not (elem f np), any (flip elem np) fs] + in if null new then np else (iter (new ++ np)) + + -- for each module in the full list, compile if depends on what needs compile + -- returns [FullPath] + mark cs = [(f,(path,st)) | + (f,(path,(st0,_))) <- sfiles1, + let st = if (elem f cs) then CSComp else st0] + + + -- Also read res if the option "retain" is present + -- Also, if a "with" file has to be compiled, read its mother file from source + + res cs = map mkRes cs where + mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of + t | (not (null [m | (m,(_,CSComp)) <- cs, + Just ms <- [lookup m allDeps], elem f ms]) + || oElem retainOpers opts) + -> if elem t [MTyResource,MTyIncResource] + then (f,(path,CSRes)) else + if t == MTyIncomplete + then (f,(path,CSComp)) else + x + _ -> x + mkRes x = x + + + + -- construct list of paths to read + paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]] + + mkName f p st = mk (p f) where + mk = case st of + CSComp -> gfFile + CSRead -> gfoFile + CSRes -> gfoFile ---- gfr + +isGFO :: FilePath -> Bool +isGFO = (== ".gfn") . takeExtensions + +gfoFile :: FilePath -> FilePath +gfoFile f = addExtension f "gfn" + +gfFile :: FilePath -> FilePath +gfFile f = addExtension f "gf" + +resModName :: ModName -> ModName +resModName = ('#':) + +-- to get imports without parsing the whole files + +getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)] +getImports ps = get [] where + get ds file0 = do + let name = dropExtension file0 ---- dropExtension file0 + (p,s) <- tryRead name + let ((typ,mname),imps) = importsOfFile s + let namebody = takeFileName name + ioeErr $ testErr (mname == namebody) $ + "module name" +++ mname +++ "differs from file name" +++ namebody + case imps of + _ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read + [] -> return $ (((typ,name),[]),p):ds + _ -> do + let files = map (gfFile . fst) imps + foldM get ((((typ,name),imps),p):ds) files + tryRead name = do + file <- do + let file_gf = gfFile name + b <- doesFileExistPath ps file_gf -- try gf file first + if b then return file_gf else do + return (gfoFile name) -- gfo next + + readFileIfPath ps $ file + + + +-- internal module dep information + +data ModUse = + MUReuse + | MUInstance + | MUComplete + | MUOther + deriving (Eq,Show) + +data ModTyp = + MTyResource + | MTyIncomplete + | MTyIncResource -- interface, incomplete resource + | MTyOther + deriving (Eq,Show) + +type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) + +importsOfFile :: String -> ModuleHeader +importsOfFile = + getModuleHeader . -- analyse into mod header + filter (not . spec) . -- ignore keywords and special symbols + unqual . -- take away qualifiers + unrestr . -- take away union restrictions + takeWhile (not . term) . -- read until curly or semic + lexs . -- analyse into lexical tokens + unComm -- ignore comments before the headed line + where + term = flip elem ["{",";"] + spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"] + unqual ws = case ws of + "(":q:ws' -> unqual ws' + w:ws' -> w:unqual ws' + _ -> ws + unrestr ws = case ws of + "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws' + w:ws' -> w:unrestr ws' + _ -> ws + +getModuleHeader :: [String] -> ModuleHeader -- with, reuse +getModuleHeader ws = case ws of + "incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in + case ty of + MTyResource -> ((MTyIncResource,name),us) + _ -> ((MTyIncomplete,name),us) + "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in + ((MTyIncResource,name),us) + + "resource":name:ws2 -> case ws2 of + "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)]) + m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + ms -> ((MTyResource,name),[(n,MUOther) | n <- ms]) + + "instance":name:m:ws2 -> case ws2 of + "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)]) + n:"with":ms -> + ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms]) + ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms]) + + "concrete":name:a:ws2 -> case span (/= "with") ws2 of + + (es,_:ms) -> ((MTyOther,name), + [(m,MUOther) | m <- es] ++ + [(n,MUComplete) | n <- ms]) + --- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + (ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms]) + + _:name:ws2 -> case ws2 of + "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)]) + ---- m:n:"with":ms -> + ---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms]) + m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + ms -> ((MTyOther,name),[(n,MUOther) | n <- ms]) + _ -> error "the file is empty" + +unComm s = case s of + '-':'-':cs -> unComm $ dropWhile (/='\n') cs + '{':'-':cs -> dpComm cs + c:cs -> c : unComm cs + _ -> s + +dpComm s = case s of + '-':'}':cs -> unComm cs + c:cs -> dpComm cs + _ -> s + +lexs s = x:xs where + (x,y) = head $ lex s + xs = if null y then [] else lexs y + +-- | options can be passed to the compiler by comments in @--#@, in the main file +getOptionsFromFile :: FilePath -> IO Options +getOptionsFromFile file = do + s <- readFileIfStrict file + let ls = filter (isPrefixOf "--#") $ lines s + return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls + +-- | check if old GF file +isOldFile :: FilePath -> IO Bool +isOldFile f = do + s <- readFileIfStrict f + let s' = unComm s + return $ not (null s') && old (head (words s')) + where + old = flip elem $ words + "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule" + + + +-- | old GF tolerated newlines in quotes. No more supported! +fixNewlines :: String -> String +fixNewlines s = case s of + '"':cs -> '"':mk cs + c :cs -> c:fixNewlines cs + _ -> s + where + mk s = case s of + '\\':'"':cs -> '\\':'"': mk cs + '"' :cs -> '"' :fixNewlines cs + '\n' :cs -> '\\':'n': mk cs + c :cs -> c : mk cs + _ -> s + diff --git a/src-3.0/GF/Devel/ModDeps.hs b/src-3.0/GF/Devel/ModDeps.hs new file mode 100644 index 000000000..ec5702910 --- /dev/null +++ b/src-3.0/GF/Devel/ModDeps.hs @@ -0,0 +1,153 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/Optimize.hs b/src-3.0/GF/Devel/Optimize.hs new file mode 100644 index 000000000..b44f6a53d --- /dev/null +++ b/src-3.0/GF/Devel/Optimize.hs @@ -0,0 +1,299 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/OptimizeGF.hs b/src-3.0/GF/Devel/OptimizeGF.hs new file mode 100644 index 000000000..99e33941f --- /dev/null +++ b/src-3.0/GF/Devel/OptimizeGF.hs @@ -0,0 +1,271 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/Options.hs b/src-3.0/GF/Devel/Options.hs new file mode 100644 index 000000000..9a4087096 --- /dev/null +++ b/src-3.0/GF/Devel/Options.hs @@ -0,0 +1,269 @@ +module GF.Devel.Options + ( + Err(..), -- FIXME: take from somewhere else + + Options(..), + Mode(..), Phase(..), OutputFormat(..), Optimization(..), + parseOptions, helpMessage + ) where + +import Control.Monad +import Data.Char (toLower) +import Data.List +import Data.Maybe +import System.Console.GetOpt +import System.FilePath + + + + + +usageHeader :: String +usageHeader = unlines + ["Usage: gfc [OPTIONS] [FILE [...]]", + "", + "How each FILE is handled depends on the file name suffix:", + "", + ".gf Normal or old GF source, will be compiled.", + ".gfc Compiled GF source, will be loaded as is.", + ".gfe Example-based GF source, will be converted to .gf and compiled.", + ".ebnf Extended BNF format, will be converted to .gf and compiled.", + ".cf Context-free (BNF) format, will be converted to .gf and compiled.", + "", + "If multiple FILES are given, they must be normal GF source, .gfc or .gfe files.", + "For the other input formats, only one file can be given.", + "", + "Command-line options:"] + + +helpMessage :: String +helpMessage = usageInfo usageHeader optDescr + +-- Error monad + +type ErrorMsg = String + +data Err a = Ok a | Errors [ErrorMsg] + deriving (Read, Show, Eq) + +instance Monad Err where + return = Ok + fail e = Errors [e] + Ok a >>= f = f a + Errors s >>= f = Errors s + +errors :: [ErrorMsg] -> Err a +errors = Errors + +-- Types + +data Mode = Version | Help | Interactive | Compiler + deriving (Show,Eq,Ord) + +data Phase = Preproc | Convert | Compile | Link + deriving (Show,Eq,Ord) + +data Encoding = UTF_8 | ISO_8859_1 + deriving (Show,Eq,Ord) + +data OutputFormat = FmtGFCC | FmtJS + deriving (Show,Eq,Ord) + +data Optimization = OptStem | OptCSE + deriving (Show,Eq,Ord) + +data Warning = WarnMissingLincat + deriving (Show,Eq,Ord) + +data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypecheck | DumpRefresh | DumpOptimize | DumpCanon + deriving (Show,Eq,Ord) + +data ModuleOptions = ModuleOptions { + optPreprocessors :: [String], + optEncoding :: Encoding, + optOptimizations :: [Optimization], + optLibraryPath :: [FilePath], + optSpeechLanguage :: Maybe String, + optBuildParser :: Bool, + optWarnings :: [Warning], + optDump :: [Dump] + } + deriving (Show) + +data Options = Options { + optMode :: Mode, + optStopAfterPhase :: Phase, + optVerbosity :: Int, + optShowCPUTime :: Bool, + optEmitGFO :: Bool, + optGFODir :: FilePath, + optOutputFormats :: [OutputFormat], + optOutputName :: Maybe String, + optOutputFile :: Maybe FilePath, + optOutputDir :: FilePath, + optForceRecomp :: Bool, + optProb :: Bool, + optStartCategory :: Maybe String, + optModuleOptions :: ModuleOptions + } + deriving (Show) + +-- Option parsing + +parseOptions :: [String] -> Err (Options, [FilePath]) +parseOptions args = case errs of + [] -> do o <- foldM (\o f -> f o) defaultOptions opts + return (o, files) + _ -> errors errs + where (opts, files, errs) = getOpt RequireOrder optDescr args + +parseModuleFlags :: Options -> [(String,String)] -> Err ModuleOptions +parseModuleFlags opts flags = foldr setOpt (optModuleOptions opts) moduleOptDescr + where + setOpt (Option _ ss arg _) d + | null values = d + | otherwise = case arg of + NoArg a -> + ReqArg (String -> a) _ -> +OptArg (Maybe String -> a) String +last values + where values = [v | (k,v) <- flags, k `elem` ss ] + +-- Default options + +defaultModuleOptions :: ModuleOptions +defaultModuleOptions = ModuleOptions { + optPreprocessors = [], + optEncoding = ISO_8859_1, + optOptimizations = [OptStem,OptCSE], + optLibraryPath = [], + optSpeechLanguage = Nothing, + optBuildParser = True, + optWarnings = [], + optDump = [] + } + +defaultOptions :: Options +defaultOptions = Options { + optMode = Interactive, + optStopAfterPhase = Link, + optVerbosity = 1, + optShowCPUTime = False, + optEmitGFO = True, + optGFODir = ".", + optOutputFormats = [FmtGFCC], + optOutputName = Nothing, + optOutputFile = Nothing, + optOutputDir = ".", + optForceRecomp = False, + optProb = False, + optStartCategory = Nothing, + optModuleOptions = defaultModuleOptions + } + +-- Option descriptions + +moduleOptDescr :: [OptDescr (ModuleOptions -> Err ModuleOptions)] +moduleOptDescr = + [ + Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", + Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", + Option [] ["preproc"] (ReqArg preproc "CMD") + (unlines ["Use CMD to preprocess input files.", + "Multiple preprocessors can be used by giving this option multiple times."]), + Option [] ["stem"] (onOff (optimize OptStem) True) "Perform stem-suffix analysis (default on).", + Option [] ["cse"] (onOff (optimize OptCSE) True) "Perform common sub-expression elimination (default on).", + Option [] ["parser"] (onOff parser True) "Build parser (default on).", + Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar." + ] + where + addLibDir x o = return $ o { optLibraryPath = x:optLibraryPath o } + setLibPath x o = return $ o { optLibraryPath = splitInModuleSearchPath x } + preproc x o = return $ o { optPreprocessors = optPreprocessors o ++ [x] } + optimize x b o = return $ o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) } + parser x o = return $ o { optBuildParser = x } + language x o = return $ o { optSpeechLanguage = Just x } + +optDescr :: [OptDescr (Options -> Err Options)] +optDescr = + [ + Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", + Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", + Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo.", + Option ['V'] ["version"] (NoArg (mode Version)) "Display GF version number.", + Option ['?','h'] ["help"] (NoArg (mode Help)) "Show help message.", + Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.", + Option ['q'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", + Option [] ["batch"] (NoArg (mode Compiler)) "Run in batch compiler mode.", + Option [] ["interactive"] (NoArg (mode Interactive)) "Run in interactive mode (default).", + Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.", + Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).", + Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).", + Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.", + Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", + Option ['f'] ["output-format"] (ReqArg outFmt "FMT") + (unlines ["Output format. FMT can be one of:", + "Multiple concrete: gfcc (default), gar, js, ...", + "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", + "Abstract only: haskell, ..."]), + Option ['n'] ["output-name"] (ReqArg outName "NAME") + ("Use NAME as the name of the output. This is used in the output file names, " + ++ "with suffixes depending on the formats, and, when relevant, " + ++ "internally in the output."), + Option ['o'] ["output-file"] (ReqArg outFile "FILE") + "Save output in FILE (default is out.X, where X depends on output format.", + Option ['D'] ["output-dir"] (ReqArg outDir "DIR") + "Save output files (other than .gfc files) in DIR.", + Option [] ["src","force-recomp"] (NoArg (forceRecomp True)) + "Always recompile from source, i.e. disable recompilation checking.", + Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", + Option [] ["startcat"] (ReqArg startcat "CAT") "Use CAT as the start category in the generated grammar." + ] ++ map (fmap onModuleOptions) moduleOptDescr + where phase x o = return $ o { optStopAfterPhase = x } + mode x o = return $ o { optMode = x } + verbosity mv o = case mv of + Nothing -> return $ o { optVerbosity = 3 } + Just v -> case reads v of + [(i,"")] | i >= 0 -> return $ o { optVerbosity = i } + _ -> fail $ "Bad verbosity: " ++ show v + cpu x o = return $ o { optShowCPUTime = x } + emitGFO x o = return $ o { optEmitGFO = x } + gfoDir x o = return $ o { optGFODir = x } + outFmt x o = readOutputFormat x >>= \f -> + return $ o { optOutputFormats = optOutputFormats o ++ [f] } + outName x o = return $ o { optOutputName = Just x } + outFile x o = return $ o { optOutputFile = Just x } + outDir x o = return $ o { optOutputDir = x } + forceRecomp x o = return $ o { optForceRecomp = x } + prob x o = return $ o { optProb = x } + startcat x o = return $ o { optStartCategory = Just x } + +onModuleOptions :: Monad m => (ModuleOptions -> m ModuleOptions) -> Options -> m Options +onModuleOptions f o = do mo' <- f (optModuleOptions o) + return $ o { optModuleOptions = mo' } + +instance Functor OptDescr where + fmap f (Option cs ss d s) = Option cs ss (fmap f d) s + +instance Functor ArgDescr where + fmap f (NoArg x) = NoArg (f x) + fmap f (ReqArg g s) = ReqArg (f . g) s + fmap f (OptArg g s) = OptArg (f . g) s + +outputFormats :: [(String,OutputFormat)] +outputFormats = + [("gfcc", FmtGFCC), + ("js", FmtJS)] + +onOff :: Monad m => (Bool -> (a -> m a)) -> Bool -> ArgDescr (a -> m a) +onOff f def = OptArg g "[on,off]" + where g ma x = do b <- maybe (return def) readOnOff ma + f b x + readOnOff x = case map toLower x of + "on" -> return True + "off" -> return False + _ -> fail $ "Expected [on,off], got: " ++ show x + +readOutputFormat :: Monad m => String -> m OutputFormat +readOutputFormat s = + maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats diff --git a/src-3.0/GF/Devel/PrGrammar.hs b/src-3.0/GF/Devel/PrGrammar.hs new file mode 100644 index 000000000..44d1c3200 --- /dev/null +++ b/src-3.0/GF/Devel/PrGrammar.hs @@ -0,0 +1,233 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/PrintGFCC.hs b/src-3.0/GF/Devel/PrintGFCC.hs new file mode 100644 index 000000000..c7e668884 --- /dev/null +++ b/src-3.0/GF/Devel/PrintGFCC.hs @@ -0,0 +1,21 @@ +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-3.0/GF/Devel/README-testgf3 b/src-3.0/GF/Devel/README-testgf3 new file mode 100644 index 000000000..0d1b6e80a --- /dev/null +++ b/src-3.0/GF/Devel/README-testgf3 @@ -0,0 +1,49 @@ +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-3.0/GF/Devel/ReadFiles.hs b/src-3.0/GF/Devel/ReadFiles.hs new file mode 100644 index 000000000..a10ee1991 --- /dev/null +++ b/src-3.0/GF/Devel/ReadFiles.hs @@ -0,0 +1,196 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/TC.hs b/src-3.0/GF/Devel/TC.hs new file mode 100644 index 000000000..5c439f671 --- /dev/null +++ b/src-3.0/GF/Devel/TC.hs @@ -0,0 +1,299 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/TestGF3.hs b/src-3.0/GF/Devel/TestGF3.hs new file mode 100644 index 000000000..da4b5c8f6 --- /dev/null +++ b/src-3.0/GF/Devel/TestGF3.hs @@ -0,0 +1,9 @@ +module Main where + +import GF.Devel.Compile.GFC + +import System (getArgs) + +main = do + xx <- getArgs + mainGFC xx diff --git a/src-3.0/GF/Devel/TypeCheck.hs b/src-3.0/GF/Devel/TypeCheck.hs new file mode 100644 index 000000000..818b48a10 --- /dev/null +++ b/src-3.0/GF/Devel/TypeCheck.hs @@ -0,0 +1,311 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Devel/UseIO.hs b/src-3.0/GF/Devel/UseIO.hs new file mode 100644 index 000000000..afbf00efd --- /dev/null +++ b/src-3.0/GF/Devel/UseIO.hs @@ -0,0 +1,298 @@ +{-# 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-3.0/GF/Devel/gf-code.txt b/src-3.0/GF/Devel/gf-code.txt new file mode 100644 index 000000000..e8954bedf --- /dev/null +++ b/src-3.0/GF/Devel/gf-code.txt @@ -0,0 +1,66 @@ +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-3.0/GF/Devel/gf3.txt b/src-3.0/GF/Devel/gf3.txt new file mode 100644 index 000000000..56feeba2a --- /dev/null +++ b/src-3.0/GF/Devel/gf3.txt @@ -0,0 +1,84 @@ +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-3.0/GF/Embed/EmbedAPI.hs b/src-3.0/GF/Embed/EmbedAPI.hs new file mode 100644 index 000000000..43e4f2546 --- /dev/null +++ b/src-3.0/GF/Embed/EmbedAPI.hs @@ -0,0 +1,114 @@ +---------------------------------------------------------------------- +-- | +-- Module : EmbedAPI +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: +-- > CVS $Author: +-- > CVS $Revision: +-- +-- Reduced Application Programmer's Interface to GF, meant for +-- embedded GF systems. AR 10/5/2005 +----------------------------------------------------------------------------- + +module GF.Embed.EmbedAPI where + +import GF.Compile.ShellState (ShellState,grammar2shellState,canModules,stateGrammarOfLang,abstract,grammar,firstStateGrammar,allLanguages,allCategories,stateOptions,firstAbsCat) +import GF.UseGrammar.Linear (linTree2string) +import GF.UseGrammar.GetTree (string2tree) +import GF.Embed.EmbedParsing (parseString) +import GF.Canon.CMacros (noMark) +import GF.Grammar.Grammar (Trm) +import GF.Grammar.MMacros (exp2tree) +import GF.Grammar.Macros (zIdent) +import GF.Grammar.PrGrammar (prt_) +import GF.Grammar.Values (tree2exp) +import GF.Grammar.TypeCheck (annotate) +import GF.Canon.GetGFC (getCanonGrammar) +import GF.Infra.Modules (emptyMGrammar) +import GF.CF.CFIdent (string2CFCat) +import GF.Infra.UseIO +import GF.Data.Operations +import GF.Infra.Option (noOptions,useUntokenizer,options,iOpt) +import GF.Infra.Ident (prIdent) +import GF.Embed.EmbedCustom + +-- This API is meant to be used when embedding GF grammars in Haskell +-- programs. The embedded system is supposed to use the +-- .gfcm grammar format, which is first produced by the gf program. + +--------------------------------------------------- +-- Interface +--------------------------------------------------- + +type MultiGrammar = ShellState +type Language = String +type Category = String +type Tree = Trm + +file2grammar :: FilePath -> IO MultiGrammar + +linearize :: MultiGrammar -> Language -> Tree -> String +parse :: MultiGrammar -> Language -> Category -> String -> [Tree] + +linearizeAll :: MultiGrammar -> Tree -> [String] +linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)] + +parseAll :: MultiGrammar -> Category -> String -> [[Tree]] +parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])] + +readTree :: MultiGrammar -> String -> Tree +showTree :: Tree -> String + +languages :: MultiGrammar -> [Language] +categories :: MultiGrammar -> [Category] + +startCat :: MultiGrammar -> Category + +--------------------------------------------------- +-- Implementation +--------------------------------------------------- + +file2grammar file = do + can <- useIOE (error "cannot parse grammar file") $ getCanonGrammar file + return $ errVal (error "cannot build multigrammar") $ + grammar2shellState (options [iOpt "docf"]) (can,emptyMGrammar) + +linearize mgr lang = + untok . + linTree2string noMark (canModules mgr) (zIdent lang) . + errVal (error "illegal tree") . + annotate gr + where + gr = grammar sgr + sgr = stateGrammarOfLang mgr (zIdent lang) + untok = customOrDefault (stateOptions sgr) useUntokenizer customUntokenizer sgr + +parse mgr lang cat = + map tree2exp . + errVal [] . + parseString (stateOptions sgr) sgr cfcat + where + sgr = stateGrammarOfLang mgr (zIdent lang) + cfcat = string2CFCat abs cat + abs = maybe (error "no abstract syntax") prIdent $ abstract mgr + +linearizeAll mgr = map snd . linearizeAllLang mgr +linearizeAllLang mgr t = [(lang,linearize mgr lang t) | lang <- languages mgr] + +parseAll mgr cat = map snd . parseAllLang mgr cat + +parseAllLang mgr cat s = + [(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)] + +readTree mgr s = tree2exp $ string2tree (firstStateGrammar mgr) s + +showTree t = prt_ t + +languages mgr = [prt_ l | l <- allLanguages mgr] + +categories mgr = [prt_ c | (_,c) <- allCategories mgr] + +startCat = prt_ . snd . firstAbsCat noOptions . firstStateGrammar diff --git a/src-3.0/GF/Embed/EmbedCustom.hs b/src-3.0/GF/Embed/EmbedCustom.hs new file mode 100644 index 000000000..f315441c5 --- /dev/null +++ b/src-3.0/GF/Embed/EmbedCustom.hs @@ -0,0 +1,113 @@ +---------------------------------------------------------------------- +-- | +-- Module : EmbedCustom +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: +-- > CVS $Author: +-- > CVS $Revision: +-- +-- A database for customizable lexers and unlexers. Reduced version of +-- GF.API, intended for embedded GF grammars. + +----------------------------------------------------------------------------- + +module GF.Embed.EmbedCustom where + +import GF.Data.Operations +import GF.Text.Text +import GF.UseGrammar.Tokenize +import GF.UseGrammar.Morphology +import GF.Infra.Option +import GF.CF.CFIdent +import GF.Compile.ShellState +import Data.Char + +-- | useTokenizer, \"-lexer=x\" +customTokenizer :: CustomData (StateGrammar -> String -> [CFTok]) + +-- | useUntokenizer, \"-unlexer=x\" --- should be from token list to string +customUntokenizer :: CustomData (StateGrammar -> String -> String) + +-- | this is the way of selecting an item +customOrDefault :: Options -> OptFun -> CustomData a -> a +customOrDefault opts optfun db = maybe (defaultCustomVal db) id $ + customAsOptVal opts optfun db + +-- | to produce menus of custom operations +customInfo :: CustomData a -> (String, [String]) +customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c)) + +type CommandId = String + +strCI :: String -> CommandId +strCI = id + +ciStr :: CommandId -> String +ciStr = id + +ciOpt :: CommandId -> Option +ciOpt = iOpt + +newtype CustomData a = CustomData (String, [(CommandId,a)]) + +customData :: String -> [(CommandId, a)] -> CustomData a +customData title db = CustomData (title,db) + +dbCustomData :: CustomData a -> [(CommandId, a)] +dbCustomData (CustomData (_,db)) = db + +titleCustomData :: CustomData a -> String +titleCustomData (CustomData (t,_)) = t + +lookupCustom :: CustomData a -> CommandId -> Maybe a +lookupCustom = flip lookup . dbCustomData + +customAsOptVal :: Options -> OptFun -> CustomData a -> Maybe a +customAsOptVal opts optfun db = do + arg <- getOptVal opts optfun + lookupCustom db (strCI arg) + +-- | take the first entry from the database +defaultCustomVal :: CustomData a -> a +defaultCustomVal (CustomData (s,db)) = + ifNull (error ("empty database:" +++ s)) (snd . head) db + +customTokenizer = + customData "Tokenizers, selected by option -lexer=x" $ + [ + (strCI "words", const $ tokWords) + ,(strCI "literals", const $ tokLits) + ,(strCI "vars", const $ tokVars) + ,(strCI "chars", const $ map (tS . singleton)) + ,(strCI "code", const $ lexHaskell) + ,(strCI "codevars", lexHaskellVar . stateIsWord) + ,(strCI "text", const $ lexText) + ,(strCI "unglue", \gr -> map tS . decomposeWords (stateMorpho gr)) + ,(strCI "codelit", lexHaskellLiteral . stateIsWord) + ,(strCI "textlit", lexTextLiteral . stateIsWord) + ,(strCI "codeC", const $ lexC2M) + ,(strCI "codeCHigh", const $ lexC2M' True) +-- add your own tokenizers here + ] + +customUntokenizer = + customData "Untokenizers, selected by option -unlexer=x" $ + [ + (strCI "unwords", const $ id) -- DEFAULT + ,(strCI "text", const $ formatAsText) + ,(strCI "html", const $ formatAsHTML) + ,(strCI "latex", const $ formatAsLatex) + ,(strCI "code", const $ formatAsCode) + ,(strCI "concat", const $ filter (not . isSpace)) + ,(strCI "textlit", const $ formatAsTextLit) + ,(strCI "codelit", const $ formatAsCodeLit) + ,(strCI "concat", const $ concatRemSpace) + ,(strCI "glue", const $ performBinds) + ,(strCI "reverse", const $ reverse) + ,(strCI "bind", const $ performBinds) -- backward compat +-- add your own untokenizers here + ] + diff --git a/src-3.0/GF/Embed/EmbedParsing.hs b/src-3.0/GF/Embed/EmbedParsing.hs new file mode 100644 index 000000000..43909f355 --- /dev/null +++ b/src-3.0/GF/Embed/EmbedParsing.hs @@ -0,0 +1,65 @@ +---------------------------------------------------------------------- +-- | +-- Module : EmbedParsing +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: +-- > CVS $Author: +-- > CVS $Revision: +-- +-- just one parse method, for use in embedded GF systems +----------------------------------------------------------------------------- + +module GF.Embed.EmbedParsing where + +import GF.Infra.CheckM +import qualified GF.Canon.AbsGFC as C +import GF.Canon.GFC +import GF.Canon.MkGFC (trExp) ---- +import GF.Canon.CMacros +import GF.Grammar.MMacros (refreshMetas) +import GF.UseGrammar.Linear +import GF.Data.Str +import GF.CF.CF +import GF.CF.CFIdent +import GF.Infra.Ident +import GF.Grammar.TypeCheck +import GF.Grammar.Values +import GF.UseGrammar.Tokenize +import GF.CF.Profile +import GF.Infra.Option +import GF.Compile.ShellState +import GF.Embed.EmbedCustom +import GF.CF.PPrCF (prCFTree) +import qualified GF.Parsing.GFC as New + + +-- import qualified GF.Parsing.GFC as New + +import GF.Data.Operations + +import Data.List (nub) +import Control.Monad (liftM) + +-- AR 26/1/2000 -- 8/4 -- 28/1/2001 -- 9/12/2002 + +parseString :: Options -> StateGrammar -> CFCat -> String -> Err [Tree] +parseString os sg cat = liftM fst . parseStringMsg os sg cat + +parseStringMsg :: Options -> StateGrammar -> CFCat -> String -> Err ([Tree],String) +parseStringMsg os sg cat s = do + (ts,(_,ss)) <- checkStart $ parseStringC os sg cat s + return (ts,unlines ss) + +parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree] +parseStringC opts0 sg cat s = do + let opts = unionOptions opts0 $ stateOptions sg + algorithm = "f" -- default algorithm: FCFG + strategy = "bottomup" + tokenizer = customOrDefault opts useTokenizer customTokenizer sg + toks = tokenizer s + ts <- checkErr $ New.parse algorithm strategy (pInfo sg) (absId sg) cat toks + checkErr $ allChecks $ map (annotate (stateGrammarST sg) . refreshMetas []) ts + diff --git a/src-3.0/GF/Embed/TemplateApp.hs b/src-3.0/GF/Embed/TemplateApp.hs new file mode 100644 index 000000000..f8722691f --- /dev/null +++ b/src-3.0/GF/Embed/TemplateApp.hs @@ -0,0 +1,44 @@ +module Main where + +import GF.Embed.EmbedAPI +import System + +-- Simple translation application built on EmbedAPI. AR 7/10/2005 + +main :: IO () +main = do + file:_ <- getArgs + grammar <- file2grammar file + translate grammar + +translate :: MultiGrammar -> IO () +translate grammar = do + s <- getLine + if s == "quit" then return () else do + treat grammar s + translate grammar + +treat :: MultiGrammar -> String -> IO () +treat grammar s = putStrLn $ case comm of + ["lin"] -> unlines $ linearizeAll grammar $ readTree grammar rest + ["lin",lang] -> linearize grammar lang $ readTree grammar rest + ["parse",cat] -> unlines $ map showTree $ concat $ parseAll grammar cat rest + ["parse",lang,cat] -> unlines $ map showTree $ parse grammar lang cat rest + ["langs"] -> unwords $ languages grammar + ["cats"] -> unwords $ categories grammar + ["help"] -> helpMsg + _ -> "command not interpreted: " ++ s + where + (comm,rest) = (words c,drop 1 r) where + (c,r) = span (/=':') s + +helpMsg = unlines [ + "lin : ", + "lin : ", + "parse : ", + "parse : ", + "langs", + "cats", + "help", + "quit" + ] diff --git a/src-3.0/GF/Formalism/CFG.hs b/src-3.0/GF/Formalism/CFG.hs new file mode 100644 index 000000000..c38adb4e2 --- /dev/null +++ b/src-3.0/GF/Formalism/CFG.hs @@ -0,0 +1,50 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.1 $ +-- +-- CFG formalism +----------------------------------------------------------------------------- + +module GF.Formalism.CFG where + +import GF.Formalism.Utilities +import GF.Infra.Print +import GF.Data.Assoc (accumAssoc) +import GF.Data.SortedList (groupPairs) +import GF.Data.Utilities (mapSnd) + +------------------------------------------------------------ +-- type definitions + +type CFGrammar c n t = [CFRule c n t] +data CFRule c n t = CFRule c [Symbol c t] n + deriving (Eq, Ord, Show) + +type CFChart c n t = CFGrammar (Edge c) n t + + +------------------------------------------------------------ +-- building syntax charts from grammars + +grammar2chart :: (Ord n, Ord e) => CFGrammar e n t -> SyntaxChart n e +grammar2chart cfchart = accumAssoc groupSyntaxNodes $ + [ (lhs, SNode name (filterCats rhs)) | + CFRule lhs rhs name <- cfchart ] + + +---------------------------------------------------------------------- +-- pretty-printing + +instance (Print n, Print c, Print t) => Print (CFRule c n t) where + prt (CFRule cat rhs name) = prt name ++ " : " ++ prt cat ++ + ( if null rhs then "" + else " --> " ++ prtSep " " rhs ) + prtList = prtSep "\n" + + diff --git a/src-3.0/GF/Formalism/FCFG.hs b/src-3.0/GF/Formalism/FCFG.hs new file mode 100644 index 000000000..5f9656658 --- /dev/null +++ b/src-3.0/GF/Formalism/FCFG.hs @@ -0,0 +1,106 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Formalism/GCFG.hs b/src-3.0/GF/Formalism/GCFG.hs new file mode 100644 index 000000000..5242081c7 --- /dev/null +++ b/src-3.0/GF/Formalism/GCFG.hs @@ -0,0 +1,47 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:44 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.3 $ +-- +-- Basic GCFG formalism (derived from Pollard 1984) +----------------------------------------------------------------------------- + +module GF.Formalism.GCFG where + +import GF.Formalism.Utilities (SyntaxChart) +import GF.Data.Assoc (assocMap, accumAssoc) +import GF.Data.SortedList (nubsort, groupPairs) +import GF.Infra.PrintClass + +---------------------------------------------------------------------- + +type Grammar c n l t = [Rule c n l t] +data Rule c n l t = Rule (Abstract c n) (Concrete l t) + deriving (Eq, Ord, Show) + +data Abstract cat name = Abs cat [cat] name + deriving (Eq, Ord, Show) +data Concrete lin term = Cnc lin [lin] term + deriving (Eq, Ord, Show) + +---------------------------------------------------------------------- + +instance (Print c, Print n, Print l, Print t) => Print (Rule n c l t) where + prt (Rule abs cnc) = prt abs ++ " := " ++ prt cnc + prtList = prtSep "\n" + +instance (Print c, Print n) => Print (Abstract c n) where + prt (Abs cat args name) = prt name ++ ". " ++ prt cat ++ + ( if null args then "" + else " --> " ++ prtSep " " args ) + +instance (Print l, Print t) => Print (Concrete l t) where + prt (Cnc lcat args term) = prt term + ++ " : " ++ prt lcat ++ + ( if null args then "" + else " / " ++ prtSep " " args) diff --git a/src-3.0/GF/Formalism/MCFG.hs b/src-3.0/GF/Formalism/MCFG.hs new file mode 100644 index 000000000..e6aa965e7 --- /dev/null +++ b/src-3.0/GF/Formalism/MCFG.hs @@ -0,0 +1,58 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:45 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.2 $ +-- +-- Definitions of multiple context-free grammars +----------------------------------------------------------------------------- + +module GF.Formalism.MCFG where + +import Control.Monad (liftM) +import Data.List (groupBy) + +import GF.Formalism.Utilities +import GF.Formalism.GCFG + +import GF.Infra.PrintClass + + +------------------------------------------------------------ +-- grammar types + +-- | the lables in the linearization record should be in the same +-- order as specified by the linearization type @[lbl]@ +type MCFGrammar cat name lbl tok = Grammar cat name [lbl] [Lin cat lbl tok] +type MCFRule cat name lbl tok = Rule cat name [lbl] [Lin cat lbl tok] + +-- | variants are encoded as several linearizations with the same label +data Lin cat lbl tok = Lin lbl [Symbol (cat, lbl, Int) tok] + deriving (Eq, Ord, Show) + +instantiateArgs :: [cat] -> Lin cat' lbl tok -> Lin cat lbl tok +instantiateArgs args (Lin lbl lin) = Lin lbl (map instSym lin) + where instSym = mapSymbol instCat id + instCat (_, lbl, nr) = (args !! nr, lbl, nr) + +expandVariants :: Eq lbl => MCFRule cat name lbl tok -> [MCFRule cat name lbl tok] +expandVariants (Rule abs (Cnc typ typs lins)) = liftM (Rule abs . Cnc typ typs) $ + expandLins lins + where expandLins = sequence . groupBy eqLbl + eqLbl (Lin l1 _) (Lin l2 _) = l1 == l2 + + +------------------------------------------------------------ +-- pretty-printing + +instance (Print c, Print l, Print t) => Print (Lin c l t) where + prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin) + where prArg (cat, lbl, nr) = prt cat ++ "@" ++ prt nr ++ prt lbl + prtList = prtBefore "\n\t" + + + diff --git a/src-3.0/GF/Formalism/SimpleGFC.hs b/src-3.0/GF/Formalism/SimpleGFC.hs new file mode 100644 index 000000000..ea1f9dc12 --- /dev/null +++ b/src-3.0/GF/Formalism/SimpleGFC.hs @@ -0,0 +1,268 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Formalism/Utilities.hs b/src-3.0/GF/Formalism/Utilities.hs new file mode 100644 index 000000000..d1826d095 --- /dev/null +++ b/src-3.0/GF/Formalism/Utilities.hs @@ -0,0 +1,423 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Fudgets/ArchEdit.hs b/src-3.0/GF/Fudgets/ArchEdit.hs new file mode 100644 index 000000000..5bc0dc84b --- /dev/null +++ b/src-3.0/GF/Fudgets/ArchEdit.hs @@ -0,0 +1,30 @@ +---------------------------------------------------------------------- +-- | +-- Module : (Module) +-- Maintainer : (Maintainer) +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:46:05 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Fudgets.ArchEdit ( + fudlogueEdit, fudlogueWrite, fudlogueWriteUni + ) where + +import GF.Fudgets.CommandF +import GF.Fudgets.UnicodeF + +-- architecture/compiler dependent definitions for unix/ghc, if Fudgets works. +-- If not, use the modules in for-ghci + +fudlogueEdit font = fudlogueEditF ---- +fudlogueWrite = fudlogueWriteU +fudlogueWriteUni _ _ = do + putStrLn "sorry no unicode available in ghc" + + diff --git a/src-3.0/GF/Fudgets/CommandF.hs b/src-3.0/GF/Fudgets/CommandF.hs new file mode 100644 index 000000000..15af12215 --- /dev/null +++ b/src-3.0/GF/Fudgets/CommandF.hs @@ -0,0 +1,134 @@ +---------------------------------------------------------------------- +-- | +-- Module : CommandF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:15 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.6 $ +-- +-- a graphical shell for any kind of GF with Zipper editing. AR 20\/8\/2001 +----------------------------------------------------------------------------- + +module GF.Fudgets.CommandF where + +import GF.Data.Operations + +import GF.UseGrammar.Session +import GF.Shell.Commands + +import Fudgets +import GF.Fudgets.FudgetOps + +import GF.Fudgets.EventF + +-- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001 + +fudlogueEditF :: CEnv -> IO () +fudlogueEditF env = + fudlogue $ gfSizeP $ shellF ("GF 2.0- Fudget Editor") (gfF env) + +gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF + +( quitN : menusN : newN : transformN : filterN : displayN : + navigateN : viewN : outputN : saveN : _) = map show [1..] + +gfLayout = placeNL verticalP [generics,output,navigate,menus,transform] + where + generics = placeNL horizontalP (map leafNL + [newN,saveN,viewN,displayN,filterN,quitN]) + output = leafNL outputN + navigate = leafNL navigateN + menus = leafNL menusN + transform = leafNL transformN + +gfSizeP = spacerF (sizeS (Point 720 640)) + +gfOutputF env = + ((nameF outputN $ (writeFileF >+< textWindowF)) + >==< + (absF (saveSP "EMPTY") + >==< + (nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:") + >+< + mapF (displayJustStateIn env)))) + >==< + mapF Right + +gfCommandF :: CEnv -> F () SState +gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click) + +loopCommandsF :: CEnv -> F Command SState +loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env) + +mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState) +mapGfStateF env = mapstateF execFC (initSState) where + execFC e0 (Left c) = (e,[Right e,Left e]) where e = execECommand env c e0 + execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0 + +mkMenusF :: CEnv -> F SState Command +mkMenusF env = + nameF menusN $ + labAboveF "Select Action on Subterm" + (mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env)) + +getCommandsF env = + newF env >*< + viewF >*< + menuDisplayF env >*< + filterF >*< + navigateF >*< + transformF + +key2command ((key,_),_) = case key of + "Up" -> CBack 1 + "Down" -> CAhead 1 + "Left" -> CPrevMeta + "Right" -> CNextMeta + "space" -> CTop + + "d" -> CDelete + "u" -> CUndo + "v" -> CView + + _ -> CVoid + +transformF = + nameF transformN $ + mapF (either key2command id) >==< (keyboardF $ + placerF horizontalP $ + cPopupStringInputF CRefineParse "Parse" "" "Parse in concrete syntax" >*< + --- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF) + cPopupStringInputF CRefineWithTree "Term" "" "Parse term" >*< + cMenuF "Modify" termCommandMenu >*< + cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert" >*< + cButtonF CRefineRandom "Random" >*< + cButtonF CUndo "Undo" + ) + +quitButF = nameF quitN $ quitF >==< buttonF "Quit" + +newF env = nameF newN $ cMenuF "New" (newCatMenu env) +menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env +filterF = nameF filterN $ cMenuF "Filter" stringCommandMenu + +viewF = nameF viewN $ cButtonF CView "View" + +navigateF = + nameF navigateN $ + placerF horizontalP $ + cButtonF CPrevMeta "?<" >*< + cButtonF (CBack 1) "<" >*< + cButtonF CTop "Top" >*< + cButtonF CLast "Last" >*< + cButtonF (CAhead 1) ">" >*< + cButtonF CNextMeta ">?" + +cButtonF c s = mapF (const c) >==< buttonF s +cMenuF s css = menuF s css >==< mapF (\_ -> CVoid) + +cPopupStringInputF comm lab def msg = + mapF comm >==< popupStringInputF lab def msg >==< mapF (const []) + diff --git a/src-3.0/GF/Fudgets/EventF.hs b/src-3.0/GF/Fudgets/EventF.hs new file mode 100644 index 000000000..7ea058dfa --- /dev/null +++ b/src-3.0/GF/Fudgets/EventF.hs @@ -0,0 +1,51 @@ +---------------------------------------------------------------------- +-- | +-- Module : EventF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:16 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Fudgets.EventF where +import AllFudgets + +-- | The first string is the name of the key (e.g., "Down" for the down arrow key) +-- +-- The modifiers list shift, control and alt keys that were active while the +-- key was pressed. +-- +-- The last string is the text produced by the key (for keys that produce +-- printable characters, empty for control keys). +type KeyPress = ((String,[Modifiers]),String) + +keyboardF :: F i o -> F i (Either KeyPress o) +keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud + where + post (KeyEvent {type'=Pressed,keySym=sym,state=mods,keyLookup=s}) = + [((sym,mods),s)] + post _ = [] + + mask = [KeyPressMask, + EnterWindowMask, LeaveWindowMask -- because of CTT implementation + ] + +-- | Output events: +oeventF em fud = eventF em (idLeftF fud) + +-- | Feed events to argument fudget: +eventF eventmask = serCompLeftToRightF . groupF startcmds eventK + where + startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask], + XCmd $ ConfigureWindow [CWBorderWidth 0]] + eventK = K $ mapFilterSP route + where route = message low high + low (XEvt event) = Just (High (Left event)) + low _ = Nothing + high h = Just (High (Right h)) + diff --git a/src-3.0/GF/Fudgets/FudgetOps.hs b/src-3.0/GF/Fudgets/FudgetOps.hs new file mode 100644 index 000000000..4aba5eec5 --- /dev/null +++ b/src-3.0/GF/Fudgets/FudgetOps.hs @@ -0,0 +1,59 @@ +---------------------------------------------------------------------- +-- | +-- Module : FudgetOps +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:17 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- auxiliary Fudgets for GF syntax editor +----------------------------------------------------------------------------- + +module GF.Fudgets.FudgetOps where + +import Fudgets + +-- save and display + +showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud + +saveF :: F a String -> F (Either String a) (Either (String,String) String) +saveF fud = + absF (saveSP "EMPTY") + >==< + (popupStringInputF "Save" "foo.tmp" "Save to file:" >+< fud) + +saveSP :: String -> SP (Either String String) (Either (String,String) String) +saveSP contents = getSP $ \msg -> case msg of + Left file -> putSP (Left (file,contents)) (saveSP contents) + Right string -> putSP (Right string) (saveSP string) + +textWindowF = writeOutputF + +-- | to replace stringInputF by a pop-up slot behind a button +popupStringInputF :: String -> String -> String -> F String String +popupStringInputF label deflt msg = + mapF snd + >==< + (popupSizeP $ stringPopupF deflt) + >==< + mapF (\_ -> (Just msg,Nothing)) + >==< + decentButtonF label + >==< + mapF (\_ -> Click) + +decentButtonF = spacerF (sizeS (Point 80 20)) . buttonF + +popupSizeP = spacerF (sizeS (Point 240 100)) + +--- the Unicode stuff should be inserted here + +writeOutputF = moreF >==< mapF lines + +writeInputF = stringInputF + + diff --git a/src-3.0/GF/Fudgets/UnicodeF.hs b/src-3.0/GF/Fudgets/UnicodeF.hs new file mode 100644 index 000000000..024205698 --- /dev/null +++ b/src-3.0/GF/Fudgets/UnicodeF.hs @@ -0,0 +1,37 @@ +---------------------------------------------------------------------- +-- | +-- Module : UnicodeF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:17 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Fudgets.UnicodeF (fudlogueWriteU) where +import Fudgets + +import GF.Data.Operations +import GF.Text.Unicode + +-- AR 12/4/2000, 18/9/2001 (added font parameter) + +fudlogueWriteU :: String -> (String -> String) -> IO () +fudlogueWriteU fn trans = + fudlogue $ + shellF "GF Unicode Output" (writeF fn trans >+< quitButtonF) + +writeF fn trans = writeOutputF fn >==< mapF trans >==< writeInputF fn + +displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) + +writeOutputF fn = moreF' (setFont fn) >==< justWriteOutputF + +justWriteOutputF = mapF (map (wrapLines 0) . filter (/=[]) . map mkUnicode . lines) + +writeInputF fn = stringInputF' (setShowString mkUnicode . setFont fn) + diff --git a/src-3.0/GF/GFCC/API.hs b/src-3.0/GF/GFCC/API.hs new file mode 100644 index 000000000..c266a5553 --- /dev/null +++ b/src-3.0/GF/GFCC/API.hs @@ -0,0 +1,140 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/GFCC/CId.hs b/src-3.0/GF/GFCC/CId.hs new file mode 100644 index 000000000..e4efa98ba --- /dev/null +++ b/src-3.0/GF/GFCC/CId.hs @@ -0,0 +1,14 @@ +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-3.0/GF/GFCC/CheckGFCC.hs b/src-3.0/GF/GFCC/CheckGFCC.hs new file mode 100644 index 000000000..d59dba1a9 --- /dev/null +++ b/src-3.0/GF/GFCC/CheckGFCC.hs @@ -0,0 +1,186 @@ +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-3.0/GF/GFCC/ComposOp.hs b/src-3.0/GF/GFCC/ComposOp.hs new file mode 100644 index 000000000..de2522bc7 --- /dev/null +++ b/src-3.0/GF/GFCC/ComposOp.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module GF.GFCC.ComposOp (Compos(..),composOp,composOpM,composOpM_,composOpMonoid, + composOpMPlus,composOpFold) where + +import Control.Monad.Identity +import Data.Monoid + +class Compos t where + compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) + -> (forall a. t a -> m (t a)) -> t c -> m (t c) + +composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c +composOp f = runIdentity . composOpM (Identity . f) + +composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c) +composOpM = compos return ap + +composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m () +composOpM_ = composOpFold (return ()) (>>) + +composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m +composOpMonoid = composOpFold mempty mappend + +composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b +composOpMPlus = composOpFold mzero mplus + +composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b +composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) + +newtype C b a = C { unC :: b } diff --git a/src-3.0/GF/GFCC/DataGFCC.hs b/src-3.0/GF/GFCC/DataGFCC.hs new file mode 100644 index 000000000..077d62b19 --- /dev/null +++ b/src-3.0/GF/GFCC/DataGFCC.hs @@ -0,0 +1,152 @@ +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-3.0/GF/GFCC/GFCC.cf b/src-3.0/GF/GFCC/GFCC.cf new file mode 100644 index 000000000..96d68649b --- /dev/null +++ b/src-3.0/GF/GFCC/GFCC.cf @@ -0,0 +1,81 @@ +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-3.0/GF/GFCC/Generate.hs b/src-3.0/GF/GFCC/Generate.hs new file mode 100644 index 000000000..63bdb3b9a --- /dev/null +++ b/src-3.0/GF/GFCC/Generate.hs @@ -0,0 +1,70 @@ +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-3.0/GF/GFCC/LexGFCC.hs b/src-3.0/GF/GFCC/LexGFCC.hs new file mode 100644 index 000000000..c86195e3d --- /dev/null +++ b/src-3.0/GF/GFCC/LexGFCC.hs @@ -0,0 +1,349 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 3 "GF/GFCC/LexGFCC.x" #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module GF.GFCC.LexGFCC where + + + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#else +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xcb\xff\xff\xff\xeb\xff\xff\xff\x0b\x00\x00\x00\x9a\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\xb8\x01\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\xff\xff\x03\x00\x03\x00\x06\x00\xff\xff\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x04\x00\xff\xff\x03\x00\xff\xff\x07\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x05\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x07\x00\x0a\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0b\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7c\x00\x5d\x00\x3e\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[],[],[]] +{-# LINE 33 "GF/GFCC/LexGFCC.x" #-} + +tok f p s = f p s + +share :: String -> String +share = id + +data Tok = + TS !String -- reserved words and symbols + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + | T_CId !String + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + PT _ (T_CId s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "lin" (b "flags" (b "cat" (b "abstract" N N) (b "concrete" N N)) (b "grammar" (b "fun" N N) N)) (b "param" (b "lindef" (b "lincat" N N) (b "oper" N N)) (b "printname" (b "pre" N N) N)) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> [Err pos] + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c + +alex_action_1 = tok (\p s -> PT p (TS $ share s)) +alex_action_2 = tok (\p s -> PT p (eitherResIdent (T_CId . share) s)) +alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_4 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) +alex_action_5 = tok (\p s -> PT p (TI $ share s)) +alex_action_6 = tok (\p s -> PT p (TD $ share s)) +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + +{-# LINE 35 "GenericTemplate.hs" #-} + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + case s of + -1# -> (last_acc, input) + _ -> alex_scan_tkn' user orig_input len input s last_acc + +alex_scan_tkn' user orig_input len input s last_acc = + let + new_acc = check_accs (alex_accept `quickIndex` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/src-3.0/GF/GFCC/Linearize.hs b/src-3.0/GF/GFCC/Linearize.hs new file mode 100644 index 000000000..c66ff93c1 --- /dev/null +++ b/src-3.0/GF/GFCC/Linearize.hs @@ -0,0 +1,91 @@ +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-3.0/GF/GFCC/Macros.hs b/src-3.0/GF/GFCC/Macros.hs new file mode 100644 index 000000000..4897aa667 --- /dev/null +++ b/src-3.0/GF/GFCC/Macros.hs @@ -0,0 +1,121 @@ +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-3.0/GF/GFCC/OptimizeGFCC.hs b/src-3.0/GF/GFCC/OptimizeGFCC.hs new file mode 100644 index 000000000..394458041 --- /dev/null +++ b/src-3.0/GF/GFCC/OptimizeGFCC.hs @@ -0,0 +1,116 @@ +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-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs b/src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs new file mode 100644 index 000000000..ab5f184a8 --- /dev/null +++ b/src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs @@ -0,0 +1,17 @@ +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-3.0/GF/GFCC/Raw/ConvertGFCC.hs b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs new file mode 100644 index 000000000..0b010d604 --- /dev/null +++ b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs @@ -0,0 +1,277 @@ +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-3.0/GF/GFCC/Raw/GFCCRaw.cf b/src-3.0/GF/GFCC/Raw/GFCCRaw.cf new file mode 100644 index 000000000..bedaef685 --- /dev/null +++ b/src-3.0/GF/GFCC/Raw/GFCCRaw.cf @@ -0,0 +1,12 @@ +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-3.0/GF/GFCC/Raw/ParGFCCRaw.hs b/src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs new file mode 100644 index 000000000..b71904948 --- /dev/null +++ b/src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs @@ -0,0 +1,99 @@ +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-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs b/src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs new file mode 100644 index 000000000..d46d8096f --- /dev/null +++ b/src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs @@ -0,0 +1,36 @@ +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-3.0/GF/GFCC/ShowLinearize.hs b/src-3.0/GF/GFCC/ShowLinearize.hs new file mode 100644 index 000000000..f627dfd28 --- /dev/null +++ b/src-3.0/GF/GFCC/ShowLinearize.hs @@ -0,0 +1,87 @@ +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-3.0/GF/GFCC/SkelGFCC.hs b/src-3.0/GF/GFCC/SkelGFCC.hs new file mode 100644 index 000000000..6972fd3c3 --- /dev/null +++ b/src-3.0/GF/GFCC/SkelGFCC.hs @@ -0,0 +1,109 @@ +module GF.GFCC.SkelGFCC where + +-- Haskell module generated by the BNF converter + +import GF.GFCC.AbsGFCC +import GF.Data.ErrM +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transCId :: CId -> Result +transCId x = case x of + CId str -> failure x + + +transGrammar :: Grammar -> Result +transGrammar x = case x of + Grm cid cids abstract concretes -> failure x + + +transAbstract :: Abstract -> Result +transAbstract x = case x of + Abs flags fundefs catdefs -> failure x + + +transConcrete :: Concrete -> Result +transConcrete x = case x of + Cnc cid flags lindefs0 lindefs1 lindefs2 lindefs3 lindefs -> failure x + + +transFlag :: Flag -> Result +transFlag x = case x of + Flg cid str -> failure x + + +transCatDef :: CatDef -> Result +transCatDef x = case x of + Cat cid hypos -> failure x + + +transFunDef :: FunDef -> Result +transFunDef x = case x of + Fun cid type' exp -> failure x + + +transLinDef :: LinDef -> Result +transLinDef x = case x of + Lin cid term -> failure x + + +transType :: Type -> Result +transType x = case x of + DTyp hypos cid exps -> failure x + + +transExp :: Exp -> Result +transExp x = case x of + DTr cids atom exps -> failure x + EEq equations -> failure x + + +transAtom :: Atom -> Result +transAtom x = case x of + AC cid -> failure x + AS str -> failure x + AI n -> failure x + AF d -> failure x + AM n -> failure x + AV cid -> failure x + + +transTerm :: Term -> Result +transTerm x = case x of + R terms -> failure x + P term0 term -> failure x + S terms -> failure x + K tokn -> failure x + V n -> failure x + C n -> failure x + F cid -> failure x + FV terms -> failure x + W str term -> failure x + TM -> failure x + RP term0 term -> failure x + + +transTokn :: Tokn -> Result +transTokn x = case x of + KS str -> failure x + KP strs variants -> failure x + + +transVariant :: Variant -> Result +transVariant x = case x of + Var strs0 strs -> failure x + + +transHypo :: Hypo -> Result +transHypo x = case x of + Hyp cid type' -> failure x + + +transEquation :: Equation -> Result +transEquation x = case x of + Equ exps exp -> failure x + + + diff --git a/src-3.0/GF/GFCC/TestGFCC.hs b/src-3.0/GF/GFCC/TestGFCC.hs new file mode 100644 index 000000000..c379a687a --- /dev/null +++ b/src-3.0/GF/GFCC/TestGFCC.hs @@ -0,0 +1,58 @@ +-- automatically generated by BNF Converter +module Main where + + +import IO ( stdin, hGetContents ) +import System ( getArgs, getProgName ) + +import GF.GFCC.LexGFCC +import GF.GFCC.ParGFCC +import GF.GFCC.SkelGFCC +import GF.GFCC.PrintGFCC +import GF.GFCC.AbsGFCC + + + + +import GF.Data.ErrM + +type ParseFun a = [Token] -> Err a + +myLLexer = myLexer + +type Verbosity = Int + +putStrV :: Verbosity -> String -> IO () +putStrV v s = if v > 1 then putStrLn s else return () + +runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () +runFile v p f = putStrLn f >> readFile f >>= run v p + +run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () +run v p s = let ts = myLLexer s in case p ts of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrV v "Tokens:" + putStrV v $ show ts + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + showTree v tree + + + +showTree :: (Show a, Print a) => Int -> a -> IO () +showTree v tree + = do + putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree + +main :: IO () +main = do args <- getArgs + case args of + [] -> hGetContents stdin >>= run 2 pGrammar + "-s":fs -> mapM_ (runFile 0 pGrammar) fs + fs -> mapM_ (runFile 2 pGrammar) fs + + + + + diff --git a/src-3.0/GF/GFCC/doc/Eng.gf b/src-3.0/GF/GFCC/doc/Eng.gf new file mode 100644 index 000000000..c64f46313 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/Eng.gf @@ -0,0 +1,13 @@ +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-3.0/GF/GFCC/doc/Ex.gf b/src-3.0/GF/GFCC/doc/Ex.gf new file mode 100644 index 000000000..bd0b03483 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/Ex.gf @@ -0,0 +1,8 @@ +abstract Ex = { + cat + S ; NP ; VP ; + fun + Pred : NP -> VP -> S ; + She, They : NP ; + Sleep : VP ; +} diff --git a/src-3.0/GF/GFCC/doc/Swe.gf b/src-3.0/GF/GFCC/doc/Swe.gf new file mode 100644 index 000000000..1d6672371 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/Swe.gf @@ -0,0 +1,13 @@ +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-3.0/GF/GFCC/doc/Test.gf b/src-3.0/GF/GFCC/doc/Test.gf new file mode 100644 index 000000000..5cd4c5474 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/Test.gf @@ -0,0 +1,64 @@ +-- 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-3.0/GF/GFCC/doc/gfcc.html b/src-3.0/GF/GFCC/doc/gfcc.html new file mode 100644 index 000000000..8f8c478c0 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/gfcc.html @@ -0,0 +1,809 @@ + + + + +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-3.0/GF/GFCC/doc/gfcc.txt b/src-3.0/GF/GFCC/doc/gfcc.txt new file mode 100644 index 000000000..5dcf2fbdc --- /dev/null +++ b/src-3.0/GF/GFCC/doc/gfcc.txt @@ -0,0 +1,712 @@ +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-3.0/GF/GFCC/doc/old-GFCC.cf b/src-3.0/GF/GFCC/doc/old-GFCC.cf new file mode 100644 index 000000000..65657a259 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/old-GFCC.cf @@ -0,0 +1,50 @@ +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-3.0/GF/GFCC/doc/old-gfcc.txt b/src-3.0/GF/GFCC/doc/old-gfcc.txt new file mode 100644 index 000000000..6ffd9bd64 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/old-gfcc.txt @@ -0,0 +1,656 @@ +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-3.0/GF/GFCC/doc/syntax.txt b/src-3.0/GF/GFCC/doc/syntax.txt new file mode 100644 index 000000000..db8f7c149 --- /dev/null +++ b/src-3.0/GF/GFCC/doc/syntax.txt @@ -0,0 +1,180 @@ +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-3.0/GF/GFModes.hs b/src-3.0/GF/GFModes.hs new file mode 100644 index 000000000..faab3cede --- /dev/null +++ b/src-3.0/GF/GFModes.hs @@ -0,0 +1,112 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : Aarne Ranta +-- Stability : (stability) +-- Portability : (portability) +-- +-- > CVS $Date: 2005/10/06 10:02:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.8 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.GFModes (gfInteract, gfBatch, batchCompile) where + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Compile.ShellState +import GF.Shell.ShellCommands +import GF.Shell +import GF.Shell.CommandL (execCommandHistory) +import GF.Shell.SubShell +import GF.Shell.PShell +import GF.Shell.JGF +import Data.Char (isSpace) + +-- separated from GF Main 24/6/2003 + +gfInteract :: HState -> IO HState +gfInteract st@(env,hist@(his,_,_,_)) = do + -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch. + (s,cs) <- getCommandLines st + case ifImpure cs of + + -- these are the three impure commands + Just (ICQuit,_) -> do + ifNotSilent "See you." + return st + Just (ICExecuteHistory file,_) -> do + ss <- readFileIf file + let co = pCommandLines st ss + st' <- execLinesH s co st + gfInteract st' + Just (ICEarlierCommand i,_) -> do + let line = earlierCommandH st i + co = pCommandLine st $ words line + st' <- execLinesH line [co] st -- s would not work in execLinesH + gfInteract st' + + Just (ICReload,_) -> case dropWhile (not . isImport) his of + line:_ -> do + let co = pCommandLine st $ words line + st' <- execLinesH line [co] st + gfInteract st' + _ -> do + putStrLn "No previous import" + gfInteract st + + Just (ICEditSession,os) -> case getOptVal os useFile of + Just file -> do + s <- readFileIf file + (env',tree) <- execCommandHistory env s + gfInteract st + _ -> + editSession (addOptions os opts) env >> gfInteract st + Just (ICTranslateSession,os) -> + translateSession (addOptions os opts) env >> gfInteract st + + -- this is a normal command sequence + _ -> do + st' <- execLinesH s cs st + gfInteract st' + where + opts = globalOptions env + ifNotSilent c = + if oElem beSilent opts then return () else putStrLnFlush c + isImport l = case words l of + "i":_ -> True + "import":_ -> True + _ -> False + +gfBatch :: HState -> IO HState +gfBatch st@(sh,_) = do + (s,cs) <- getCommandLinesBatch st + if s == "q" then return st else do + st' <- if all isSpace s then return st else do + putVe "" + putVe s + putVe "" + putVe "" + (_,st') <- execLines True cs st + putVe "" + return st' + gfBatch st' + where + putVe = putVerb st + +putVerb st@(sh,_) s = if (oElem beSilent (globalOptions sh)) + then return () + else putStrLnFlush s + +batchCompile :: Options -> FilePath -> IO () +batchCompile os file = do + let file' = mkGFC file + let st = initHState $ addGlobalOptions (options [iOpt "make"]) emptyShellState + let s = "i -o" +++ (unwords $ map ('-':) $ words $ prOpts os) +++ file + let cs = pCommandLines st s + execLines True cs st + return () + +mkGFC = reverse . ("cfg" ++) . dropWhile (/='.') . reverse diff --git a/src-3.0/GF/Grammar/AbsCompute.hs b/src-3.0/GF/Grammar/AbsCompute.hs new file mode 100644 index 000000000..57e21f1dd --- /dev/null +++ b/src-3.0/GF/Grammar/AbsCompute.hs @@ -0,0 +1,145 @@ +---------------------------------------------------------------------- +-- | +-- Module : AbsCompute +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/02 20:50:19 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.8 $ +-- +-- computation in abstract syntax w.r.t. explicit definitions. +-- +-- old GF computation; to be updated +----------------------------------------------------------------------------- + +module GF.Grammar.AbsCompute (LookDef, + compute, + computeAbsTerm, + computeAbsTermIn, + beta + ) where + +import GF.Data.Operations + +import GF.Grammar.Abstract +import GF.Grammar.PrGrammar +import GF.Grammar.LookAbs +import GF.Grammar.Compute + +import Debug.Trace +import Data.List(intersperse) +import Control.Monad (liftM, liftM2) + +-- for debugging +tracd m t = t +-- tracd = trace + +compute :: GFCGrammar -> Exp -> Err Exp +compute = computeAbsTerm + +computeAbsTerm :: GFCGrammar -> Exp -> Err Exp +computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] + +-- | a hack to make compute work on source grammar as well +type LookDef = Ident -> Ident -> Err (Maybe Term) + +computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp +computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where + compt vv t = case t of +-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) +-- Abs x b -> liftM (Abs x) (compt (x:vv) b) + _ -> do + let t' = beta vv t + (yy,f,aa) <- termForm t' + let vv' = yy ++ vv + aa' <- mapM (compt vv') aa + case look f of + Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $ + case findMatch eqs aa' of + Ok (d,g) -> do + --- let (xs,ts) = unzip g + --- ts' <- alphaFreshAll vv' ts + let g' = g --- zip xs ts' + d' <- compt vv' $ substTerm vv' g' d + tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d' + _ -> tracd ("no match" +++ prt t') $ + do + let v = mkApp f aa' + return $ mkAbs yy $ v + Just d -> tracd ("define" +++ prt t') $ do + da <- compt vv' $ mkApp d aa' + return $ mkAbs yy $ da + _ -> do + let t2 = mkAbs yy $ mkApp f aa' + tracd ("not defined" +++ prt_ t2) $ return t2 + + look t = case t of + (Q m f) -> case lookd m f of + Ok (Just EData) -> Nothing -- canonical --- should always be QC + Ok md -> md + _ -> Nothing + Eqs _ -> return t ---- for nested fn + _ -> Nothing + +beta :: [Ident] -> Exp -> Exp +beta vv c = case c of + Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) + App f a -> + let (a',f') = (beta vv a, beta vv f) in + case f' of + Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) + _ -> (if a'==a && f'==f then id else beta vv) $ App f' a' + Prod x a b -> Prod x (beta vv a) (beta (x:vv) b) + Abs x b -> Abs x (beta (x:vv) b) + _ -> c + +-- special version of pattern matching, to deal with comp under lambda + +findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) +findMatch cases terms = case cases of + [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + (patts,_):_ | length patts /= length terms -> + Bad ("wrong number of args for patterns :" +++ + unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) + (patts,val):cc -> case mapM tryMatch (zip patts terms) of + Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs) + _ -> findMatch cc terms + +tryMatch :: (Patt, Term) -> Err [(Ident, Term)] +tryMatch (p,t) = do + t' <- termForm t + trym p t' + where + + trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- + case (p,t') of + (PV IW, _) | notMeta t -> return [] -- optimization with wildcard + (PV x, _) | notMeta t -> return [(x,t)] + (PString s, ([],K i,[])) | s==i -> return [] + (PInt s, ([],EInt i,[])) | s==i -> return [] + (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? + (PP q p pp, ([], QC r f, tt)) | + p `eqStrIdent` f && length pp == length tt -> do + matches <- mapM tryMatch (zip pp tt) + return (concat matches) + (PP q p pp, ([], Q r f, tt)) | + p `eqStrIdent` f && length pp == length tt -> do + matches <- mapM tryMatch (zip pp tt) + return (concat matches) + (PT _ p',_) -> trym p' t' + (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) + (PAs x p',_) -> do + subst <- trym p' t' + return $ (x,t) : subst + _ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t) + + notMeta e = case e of + Meta _ -> False + App f a -> notMeta f && notMeta a + Abs _ b -> notMeta b + _ -> True + + prtm p g = + prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g] diff --git a/src-3.0/GF/Grammar/Abstract.hs b/src-3.0/GF/Grammar/Abstract.hs new file mode 100644 index 000000000..c03783a52 --- /dev/null +++ b/src-3.0/GF/Grammar/Abstract.hs @@ -0,0 +1,38 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/AppPredefined.hs b/src-3.0/GF/Grammar/AppPredefined.hs new file mode 100644 index 000000000..fa0048c80 --- /dev/null +++ b/src-3.0/GF/Grammar/AppPredefined.hs @@ -0,0 +1,159 @@ +---------------------------------------------------------------------- +-- | +-- 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 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",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-3.0/GF/Grammar/Compute.hs b/src-3.0/GF/Grammar/Compute.hs new file mode 100644 index 000000000..c76058cc2 --- /dev/null +++ b/src-3.0/GF/Grammar/Compute.hs @@ -0,0 +1,426 @@ +---------------------------------------------------------------------- +-- | +-- Module : Compute +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/01 15:39:12 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.19 $ +-- +-- Computation of source terms. Used in compilation and in @cc@ command. +----------------------------------------------------------------------------- + +module GF.Grammar.Compute (computeConcrete, computeTerm,computeConcreteRec) where + +import GF.Data.Operations +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Data.Str +import GF.Grammar.PrGrammar +import GF.Infra.Modules +import GF.Grammar.Macros +import GF.Grammar.Lookup +import GF.Grammar.Refresh +import GF.Grammar.PatternMatch +import GF.Grammar.Lockfield (isLockLabel) ---- + +import GF.Grammar.AppPredefined + +import Data.List (nub,intersperse) +import Control.Monad (liftM2, liftM) + +-- | computation of concrete syntax terms into normal form +-- used mainly for partial evaluation +computeConcrete :: SourceGrammar -> Term -> Err Term +computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t +computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t + +computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term +computeTerm = computeTermOpt False + +-- rec=True is used if it cannot be assumed that looked-up constants +-- have already been computed (mainly with -optimize=noexpand in .gfr) + +computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term +computeTermOpt rec gr = comput True where + + comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging + case t of + + Q (IC "Predef") _ -> return t + Q p c -> look p c + + -- if computed do nothing + Computed t' -> return $ unComputed t' + + Vr x -> do + t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g + case t' of + _ | t == t' -> return t + _ -> comp g t' + + -- Abs x@(IA _) b -> do + Abs x b | full -> do + let (xs,b1) = termFormCnc t + b' <- comp ([(x,Vr x) | x <- xs] ++ g) b1 + return $ mkAbs xs b' + -- b' <- comp (ext x (Vr x) g) b + -- return $ Abs x b' + Abs _ _ -> return t -- hnf + + Let (x,(_,a)) b -> do + a' <- comp g a + comp (ext x a' g) b + + Prod x a b -> do + a' <- comp g a + b' <- comp (ext x (Vr x) g) b + return $ Prod x a' b' + + -- beta-convert + App f a -> case appForm t of + (h,as) | length as > 1 -> do + h' <- hnf g h + as' <- mapM (comp g) as + case h' of + _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as') + c@(QC _ _) -> do + return $ mkApp c as' + Q (IC "Predef") f -> do + (t',b) <- appPredefined (mkApp h' as') + if b then return t' else comp g t' + + Abs _ _ -> do + let (xs,b) = termFormCnc h' + let g' = (zip xs as') ++ g + let as2 = drop (length xs) as' + let xs2 = drop (length as') xs + b' <- comp g' (mkAbs xs2 b) + if null as2 then return b' else comp g (mkApp b' as2) + + _ -> compApp g (mkApp h' as') + _ -> compApp g t + + P t l | isLockLabel l -> return $ R [] + ---- a workaround 18/2/2005: take this away and find the reason + ---- why earlier compilation destroys the lock field + + + P t l -> do + t' <- comp g t + case t' of + FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants + R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ + lookup l $ reverse r + + ExtR a (R b) -> + case comp g (P (R b) l) of + Ok v -> return v + _ -> comp g (P a l) + +--- { - --- this is incorrect, since b can contain the proper value + ExtR (R a) b -> -- NOT POSSIBLE both a and b records! + case comp g (P (R a) l) of + Ok v -> return v + _ -> comp g (P b l) +--- - } --- + + Alias _ _ r -> comp g (P r l) + + S (T i cs) e -> prawitz g i (flip P l) cs e + S (V i cs) e -> prawitzV g i (flip P l) cs e + + _ -> returnC $ P t' l + + PI t l i -> comp g $ P t l ----- + + S t@(T ti cc) v -> do + v' <- comp g v + case v' of + FV vs -> do + ts' <- mapM (comp g . S t) vs + return $ variants ts' + _ -> case ti of +{- + TComp _ -> do + case term2patt v' of + Ok p' -> case lookup p' cc of + Just u -> comp g u + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + _ -> do + t' <- comp g t + return $ S t' v' +-} + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> do + t' <- comp g t + return $ S t' v' -- if v' is not canonical + + + S t v -> do + + t' <- case t of +-- T _ _ -> return t +-- V _ _ -> return t + _ -> comp g t + + v' <- comp g v + + case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants + _ -> case t' of + FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants + + T _ [(PV IW,c)] -> comp g c --- an optimization + T _ [(PT _ (PV IW),c)] -> comp g c + + T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization + T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c + + -- course-of-values table: look up by index, no pattern matching needed + V ptyp ts -> do + vs <- allParamValues gr ptyp + case lookup v' (zip vs [0 .. length vs - 1]) of + Just i -> comp g $ ts !! i +----- _ -> prtBad "selection" $ S t' v' -- debug + _ -> return $ S t' v' -- if v' is not canonical + + T (TComp _) cs -> do + case term2patt v' of + Ok p' -> case lookup p' cs of + Just u -> comp g u + _ -> return $ S t' v' -- if v' is not canonical + _ -> return $ S t' v' + + T _ cc -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + Alias _ _ d -> comp g (S d v') + + S (T i cs) e -> prawitz g i (flip S v') cs e + S (V i cs) e -> prawitzV g i (flip S v') cs e + _ -> returnC $ S t' v' + + -- normalize away empty tokens + K "" -> return Empty + + -- glue if you can + Glue x0 y0 -> do + x <- comp g x0 + y <- comp g y0 + case (x,y) of + (FV ks,_) -> do + kys <- mapM (comp g . flip Glue y) ks + return $ variants kys + (_,FV ks) -> do + xks <- mapM (comp g . Glue x) ks + return $ variants xks + + (Alias _ _ d, y) -> comp g $ Glue d y + (x, Alias _ _ d) -> comp g $ Glue x d + + (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e + (s, S (T i cs) e) -> prawitz g i (Glue s) cs e + (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e + (s, S (V i cs) e) -> prawitzV g i (Glue s) cs e + (_,Empty) -> return x + (Empty,_) -> return y + (K a, K b) -> return $ K (a ++ b) + (_, Alts (d,vs)) -> do +---- (K a, Alts (d,vs)) -> do + let glx = Glue x + comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) + (Alts _, ka) -> checks [do + y' <- strsFromTerm ka +---- (Alts _, K a) -> checks [do + x' <- strsFromTerm x -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y'] +---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] + ,return $ Glue x y + ] + (C u v,_) -> comp g $ C u (Glue v y) + + _ -> do + mapM_ checkNoArgVars [x,y] + r <- composOp (comp g) t + returnC r + + Alts _ -> do + r <- composOp (comp g) t + returnC r + + -- remove empty + C a b -> do + a' <- comp g a + b' <- comp g b + case (a',b') of + (Alts _, K a) -> checks [do + as <- strsFromTerm a' -- this may fail when compiling opers + return $ variants [ + foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as] + , + return $ C a' b' + ] + (Empty,_) -> returnC b' + (_,Empty) -> returnC a' + _ -> returnC $ C a' b' + + -- reduce free variation as much as you can + FV ts -> mapM (comp g) ts >>= returnC . variants + + -- merge record extensions if you can + ExtR r s -> do + r' <- comp g r + s' <- comp g s + case (r',s') of + (Alias _ _ d, _) -> comp g $ ExtR d s' + (_, Alias _ _ d) -> comp g $ Glue r' d + + (R rs, R ss) -> plusRecord r' s' + (RecType rs, RecType ss) -> plusRecType r' s' + _ -> return $ ExtR r' s' + + -- case-expand tables + -- if already expanded, don't expand again + T i@(TComp ty) cs -> do + -- if there are no variables, don't even go inside + cs' <- if (null g) then return cs else mapPairsM (comp g) cs +---- return $ V ty (map snd cs') + return $ T i cs' + --- this means some extra work; should implement TSh directly + TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] + + T i cs -> do + pty0 <- getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs -> do + + cs' <- mapM (compBranchOpt g) cs + sts <- mapM (matchPattern cs') vs + ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts + ps <- mapM term2patt vs + let ps' = ps --- PT ptyp (head ps) : tail ps +---- return $ V ptyp ts -- to save space, just course of values + return $ T (TComp ptyp) (zip ps' ts) + _ -> do + cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + + Alias c a d -> do + d' <- comp g d + return $ Alias c a d' -- alias only disappears in certain redexes + + -- otherwise go ahead + _ -> composOp (comp g) t >>= returnC + + where + + compApp g (App f a) = do + f' <- hnf g f + a' <- comp g a + case (f',a') of + (Abs x b, FV as) -> + mapM (\c -> comp (ext x c g) b) as >>= return . variants + (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants + (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants + (Abs x b,_) -> comp (ext x a' g) b + + (QC _ _,_) -> returnC $ App f' a' + + (Alias _ _ d, _) -> comp g (App d a') + + (S (T i cs) e,_) -> prawitz g i (flip App a') cs e + (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e + + _ -> do + (t',b) <- appPredefined (App f' a') + if b then return t' else comp g t' + + hnf = comput False + comp = comput True + + look p c + | rec = lookupResDef gr p c >>= comp [] + | otherwise = lookupResDef gr p c + +{- + look p c = case lookupResDefKind gr p c of + Ok (t,_) | noExpand p || rec -> comp [] t + Ok (t,_) -> return t + Bad s -> raise s + + noExpand p = errVal False $ do + mo <- lookupModMod gr p + return $ case getOptVal (iOpts (flags mo)) useOptimizer of + Just "noexpand" -> True + _ -> False +-} + + ext x a g = (x,a):g + + returnC = return --- . computed + + variants ts = case nub ts of + [t] -> t + ts -> FV ts + + isCan v = case v of + Con _ -> True + QC _ _ -> True + App f a -> isCan f && isCan a + R rs -> all (isCan . snd . snd) rs + _ -> False + + compBranch g (p,v) = do + let g' = contP p ++ g + v' <- comp g' v + return (p,v') + + compBranchOpt g c@(p,v) = case contP p of + [] -> return c + _ -> err (const (return c)) return $ compBranch g c + + contP p = case p of + PV x -> [(x,Vr x)] + PC _ ps -> concatMap contP ps + PP _ _ ps -> concatMap contP ps + PT _ p -> contP p + PR rs -> concatMap (contP . snd) rs + + PAs x p -> (x,Vr x) : contP p + + PSeq p q -> concatMap contP [p,q] + PAlt p q -> concatMap contP [p,q] + PRep p -> contP p + PNeg p -> contP p + + _ -> [] + + prawitz g i f cs e = do + cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs] + return $ S (T i cs') e + prawitzV g i f cs e = do + cs' <- mapM (comp g) [(f v) | v <- cs] + return $ S (V i cs') e + +-- | argument variables cannot be glued +checkNoArgVars :: Term -> Err Term +checkNoArgVars t = case t of + Vr (IA _) -> Bad $ glueErrorMsg $ prt t + Vr (IAV _) -> Bad $ glueErrorMsg $ prt t + _ -> composOp checkNoArgVars t + +glueErrorMsg s = + "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++ + "Use Prelude.bind instead." diff --git a/src-3.0/GF/Grammar/Grammar.hs b/src-3.0/GF/Grammar/Grammar.hs new file mode 100644 index 000000000..95fdce611 --- /dev/null +++ b/src-3.0/GF/Grammar/Grammar.hs @@ -0,0 +1,244 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/Lockfield.hs b/src-3.0/GF/Grammar/Lockfield.hs new file mode 100644 index 000000000..960b12983 --- /dev/null +++ b/src-3.0/GF/Grammar/Lockfield.hs @@ -0,0 +1,46 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/LookAbs.hs b/src-3.0/GF/Grammar/LookAbs.hs new file mode 100644 index 000000000..5bd4c1e41 --- /dev/null +++ b/src-3.0/GF/Grammar/LookAbs.hs @@ -0,0 +1,196 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/Lookup.hs b/src-3.0/GF/Grammar/Lookup.hs new file mode 100644 index 000000000..81a62decf --- /dev/null +++ b/src-3.0/GF/Grammar/Lookup.hs @@ -0,0 +1,275 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/MMacros.hs b/src-3.0/GF/Grammar/MMacros.hs new file mode 100644 index 000000000..dd7331685 --- /dev/null +++ b/src-3.0/GF/Grammar/MMacros.hs @@ -0,0 +1,341 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/Macros.hs b/src-3.0/GF/Grammar/Macros.hs new file mode 100644 index 000000000..7a48e7c3a --- /dev/null +++ b/src-3.0/GF/Grammar/Macros.hs @@ -0,0 +1,814 @@ +---------------------------------------------------------------------- +-- | +-- 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) + +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-3.0/GF/Grammar/PatternMatch.hs b/src-3.0/GF/Grammar/PatternMatch.hs new file mode 100644 index 000000000..b96d35b93 --- /dev/null +++ b/src-3.0/GF/Grammar/PatternMatch.hs @@ -0,0 +1,155 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/PrGrammar.hs b/src-3.0/GF/Grammar/PrGrammar.hs new file mode 100644 index 000000000..c3a21d1d6 --- /dev/null +++ b/src-3.0/GF/Grammar/PrGrammar.hs @@ -0,0 +1,286 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/Refresh.hs b/src-3.0/GF/Grammar/Refresh.hs new file mode 100644 index 000000000..bc77c1837 --- /dev/null +++ b/src-3.0/GF/Grammar/Refresh.hs @@ -0,0 +1,133 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/ReservedWords.hs b/src-3.0/GF/Grammar/ReservedWords.hs new file mode 100644 index 000000000..b440141d6 --- /dev/null +++ b/src-3.0/GF/Grammar/ReservedWords.hs @@ -0,0 +1,44 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/SGrammar.hs b/src-3.0/GF/Grammar/SGrammar.hs new file mode 100644 index 000000000..e0c001b6b --- /dev/null +++ b/src-3.0/GF/Grammar/SGrammar.hs @@ -0,0 +1,169 @@ +---------------------------------------------------------------------- +-- | +-- Module : SGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- +-- A simple format for context-free abstract syntax used e.g. in +-- generation. AR 31\/3\/2006 +-- +-- (c) Aarne Ranta 2004 under GNU GPL +-- +-- Purpose: to generate corpora. We use simple types and don't +-- guarantee the correctness of bindings\/dependences. +----------------------------------------------------------------------------- + +module GF.Grammar.SGrammar where + +import GF.Canon.GFC +import GF.Grammar.LookAbs +import GF.Grammar.PrGrammar +import GF.Grammar.Macros +import GF.Grammar.Values +import GF.Grammar.Grammar +import GF.Infra.Ident (Ident) + +import GF.Data.Operations +import GF.Data.Zipper +import GF.Infra.Option + +import Data.List + +-- (c) Aarne Ranta 2006 under GNU GPL + + +type SGrammar = BinTree SCat [SRule] +type SIdent = String +type SRule = (SFun,SType) +type SType = ([SCat],SCat) +type SCat = SIdent +type SFun = (Double,SIdent) + +allRules gr = concat [rs | (c,rs) <- tree2list gr] + +data STree = + SApp (SFun,[STree]) + | SMeta SCat + | SString String + | SInt Integer + | SFloat Double + deriving (Show,Eq) + +depth :: STree -> Int +depth t = case t of + SApp (_,ts@(_:_)) -> maximum (map depth ts) + 1 + _ -> 1 + +type Probs = BinTree Ident Double + +emptyProbs :: Probs +emptyProbs = emptyBinTree + +prProbs :: Probs -> String +prProbs = unlines . map pr . tree2list where + pr (f,p) = prt f ++ "\t" ++ show p + +------------------------------------------ +-- translate grammar to simpler form and generated trees back + +gr2sgr :: Options -> Probs -> GFCGrammar -> SGrammar +gr2sgr opts probs gr = buildTree [(c,norm (noexp c rs)) | rs@((_,(_,c)):_) <- rules] where + noe = maybe [] (chunks ',') $ getOptVal opts (aOpt "noexpand") + only = maybe [] (chunks ',') $ getOptVal opts (aOpt "doexpand") + un = getOptInt opts (aOpt "atoms") + rules = + prune $ + groupBy (\x y -> scat x == scat y) $ + sortBy (\x y -> compare (scat x) (scat y)) $ + [(trId f, ty') | (f,ty) <- funRulesOf gr, ty' <- trTy ty] + trId (_,f) = let f' = prt f in case lookupTree prt f probs of + Ok p -> (p,f') + _ -> (2.0, f') + trTy ty = case catSkeleton ty of + Ok (mcs,mc) -> [(map trCat mcs, trCat mc)] + _ -> [] + trCat (m,c) = prt c --- + scat (_,(_,c)) = c + + prune rs = maybe rs (\n -> map (onlyAtoms n) rs) $ un + + norm = fillProb + + onlyAtoms n rs = + let (rs1,rs2) = partition atom rs + in take n rs1 ++ rs2 + atom = null . fst . snd + + noexp c rs + | null only = if elem c noe then [((2.0,'?':c),([],c))] else rs + | otherwise = if elem c only then rs else [((2.0,'?':c),([],c))] + +-- for cases where explicit probability is not given (encoded as +-- p > 1) divide the remaining mass by the number of such cases + +fillProb :: [SRule] -> [SRule] +fillProb rs = [((defa p,f),ty) | ((p,f),ty) <- rs] where + defa p = if p > 1.0 then def else p + def = (1 - sum given) / genericLength nope + (nope,given) = partition (> 1.0) [p | ((p,_),_) <- rs] + +-- str2tr :: STree -> Exp +str2tr t = case t of + SApp ((_,'?':c),[]) -> mkMeta 0 -- from noexpand=c + SApp ((_,f),ts) -> mkApp (trId f) (map str2tr ts) + SMeta _ -> mkMeta 0 + SString s -> K s + SInt i -> EInt i + SFloat i -> EFloat i + where + trId = cn . zIdent + +-- tr2str :: Tree -> STree +tr2str (Tr (N (_,at,val,_,_),ts)) = case (at,val) of + (AtC (_,f), _) -> SApp ((2.0,prt_ f),map tr2str ts) + (AtM _, v) -> SMeta (catOf v) + (AtL s, _) -> SString s + (AtI i, _) -> SInt i + (AtF i, _) -> SFloat i + _ -> SMeta "FAILED_TO_GENERATE" ---- err monad! + where + catOf v = case v of + VApp w _ -> catOf w + VCn (_,c) -> prt_ c + _ -> "FAILED_TO_GENERATE_FROM_META" + + +------------------------------------------ +-- to test + +prSTree t = case t of + SApp ((_,f),ts) -> f ++ concat (map pr1 ts) + SMeta c -> '?':c + SString s -> prQuotedString s + SInt i -> show i + SFloat i -> show i + where + pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t) + pr1 t = prSTree t + +pSRule :: String -> SRule +pSRule s = case words s of + f : _ : cs -> ((2.0,f),(init cs', last cs')) + where cs' = [cs !! i | i <- [0,2..length cs - 1]] + _ -> error $ "not a rule" +++ s + +exSgr = map pSRule [ + "Pred : NP -> VP -> S" + ,"Compl : TV -> NP -> VP" + ,"PredVV : VV -> VP -> VP" + ,"DefCN : CN -> NP" + ,"ModCN : AP -> CN -> CN" + ,"john : NP" + ,"walk : VP" + ,"love : TV" + ,"try : VV" + ,"girl : CN" + ,"big : AP" + ] diff --git a/src-3.0/GF/Grammar/TC.hs b/src-3.0/GF/Grammar/TC.hs new file mode 100644 index 000000000..be52d1889 --- /dev/null +++ b/src-3.0/GF/Grammar/TC.hs @@ -0,0 +1,299 @@ +---------------------------------------------------------------------- +-- | +-- Module : TC +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/02 20:50:19 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.11 $ +-- +-- Thierry Coquand's type checking algorithm that creates a trace +----------------------------------------------------------------------------- + +module GF.Grammar.TC (AExp(..), + Theory, + checkExp, + inferExp, + checkEqs, + eqVal, + whnf + ) where + +import GF.Data.Operations +import GF.Grammar.Abstract +import GF.Grammar.AbsCompute + +import Control.Monad +import Data.List (sortBy) + +data AExp = + AVr Ident Val + | ACn QIdent Val + | AType + | AInt Integer + | AFloat Double + | AStr String + | AMeta MetaSymb Val + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp + | AEqs [([Exp],AExp)] --- not used + | AData Val + deriving (Eq,Show) + +type Theory = QIdent -> Err Val + +lookupConst :: Theory -> QIdent -> Err Val +lookupConst th f = th f + +lookupVar :: Env -> Ident -> Err Val +lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g) +-- wild card IW: no error produced, ?0 instead. + +type TCEnv = (Int,Env,Env) + +emptyTCEnv :: TCEnv +emptyTCEnv = (0,[],[]) + +whnf :: Val -> Err Val +whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug + case v of + VApp u w -> do + u' <- whnf u + w' <- whnf w + app u' w' + VClos env e -> eval env e + _ -> return v + +app :: Val -> Val -> Err Val +app u v = case u of + VClos env (Abs x e) -> eval ((x,v):env) e + _ -> return $ VApp u v + +eval :: Env -> Exp -> Err Val +eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ + case e of + Vr x -> lookupVar env x + Q m c -> return $ VCn (m,c) + QC m c -> return $ VCn (m,c) ---- == Q ? + Sort c -> return $ VType --- the only sort is Type + App f a -> join $ liftM2 app (eval env f) (eval env a) + _ -> return $ VClos env e + +eqVal :: Int -> Val -> Val -> Err [(Val,Val)] +eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ + do + w1 <- whnf u1 + w2 <- whnf u2 + let v = VGen k + case (w1,w2) of + (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) + (VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) -> + eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) + (VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) -> + liftM2 (++) + (eqVal k (VClos env1 a1) (VClos env2 a2)) + (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) + (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] + (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] + --- thus ignore qualifications; valid because inheritance cannot + --- be qualified. Simplifies annotation. AR 17/3/2005 + _ -> return [(w1,w2) | w1 /= w2] +-- invariant: constraints are in whnf + +checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)]) +checkType th tenv e = checkExp th tenv e vType + +checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) +checkExp th tenv@(k,rho,gamma) e ty = do + typ <- whnf ty + let v = VGen k + case e of + Meta m -> return $ (AMeta m typ,[]) + EData -> return $ (AData typ,[]) + + Abs x t -> case typ of + VClos env (Prod y a b) -> do + a' <- whnf $ VClos env a --- + (t',cs) <- checkExp th + (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) + return (AAbs x a' t', cs) + _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ + +-- {- --- to get deprec when checkEqs works (15/9/2005) + Eqs es -> do + bcs <- mapM (\b -> checkBranch th tenv b typ) es + let (bs,css) = unzip bcs + return (AEqs bs, concat css) +-- - } + Prod x a b -> do + testErr (typ == vType) "expected Type" + (a',csa) <- checkType th tenv a + (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b + return (AProd x a' b', csa ++ csb) + + _ -> checkInferExp th tenv e typ + +checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) +checkInferExp th tenv@(k,_,_) e typ = do + (e',w,cs1) <- inferExp th tenv e + cs2 <- eqVal k w typ + return (e',cs1 ++ cs2) + +inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)]) +inferExp th tenv@(k,rho,gamma) e = case e of + Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x + Q m c + | m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) -> + return (ACn (m,c) vType, vType, []) + | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) + QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ---- + EInt i -> return (AInt i, valAbsInt, []) + EFloat i -> return (AFloat i, valAbsFloat, []) + K i -> return (AStr i, valAbsString, []) + Sort _ -> return (AType, vType, []) + App f t -> do + (f',w,csf) <- inferExp th tenv f + typ <- whnf w + case typ of + VClos env (Prod x a b) -> do + (a',csa) <- checkExp th tenv t (VClos env a) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) + _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ + _ -> prtBad "cannot infer type of expression" e + where + predefAbs c s = case c of + IC "Int" -> return $ const $ Q cPredefAbs cInt + IC "Float" -> return $ const $ Q cPredefAbs cFloat + IC "String" -> return $ const $ Q cPredefAbs cString + _ -> Bad s + +checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)] +checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of + Eqs es -> liftM concat $ mapM checkBranch es + _ -> liftM snd $ checkExp th tenv def val + where + checkBranch (ps,df) = + let + (ps',_,vars) = foldr p2t ([],0,[]) ps + fps = mkApp (Q m f) ps' + in errIn ("branch" +++ prt fps) $ do + (aexp, typ, cs1) <- inferExp th tenv fps + let + bds = binds vars aexp + tenv' = (k, rho, bds ++ gamma) + (_,cs2) <- errIn (show bds) $ checkExp th tenv' df typ + return $ (cs1 ++ cs2) + p2t p (ps,i,g) = case p of + PW -> (meta (MetaSymb i) : ps, i+1, g) + PV IW -> (meta (MetaSymb i) : ps, i+1, g) + PV x -> (meta (MetaSymb i) : ps, i+1,upd x i g) + PString s -> ( K s : ps, i, g) + PInt n -> (EInt n : ps, i, g) + PFloat n -> (EFloat n : ps, i, g) + PP m c xs -> (mkApp (qq (m,c)) xss : ps, i', g') + where (xss,i',g') = foldr p2t ([],i,g) xs + _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" + upd x i g = (x,i) : g --- to annotate pattern variables: treat as metas + + -- notice: in vars, the sequence 0.. is sorted. In subst aexp, all + -- this occurs and nothing else. + binds vars aexp = [(x,v) | ((x,_),v) <- zip vars metas] where + metas = map snd $ sortBy (\ (x,_) (y,_) -> compare x y) $ subst aexp + subst aexp = case aexp of + AMeta (MetaSymb i) v -> [(i,v)] + AApp c a _ -> subst c ++ subst a + _ -> [] -- never matter in patterns + +checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)]) +checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ + chB tenv' ps' ty + where + + (ps',_,rho2,k') = ps2ts k ps + tenv' = (k, rho2++rho, gamma) ---- k' ? + (k,rho,gamma) = tenv + + chB tenv@(k,rho,gamma) ps ty = case ps of + p:ps2 -> do + typ <- whnf ty + case typ of + VClos env (Prod y a b) -> do + a' <- whnf $ VClos env a + (p', sigma, binds, cs1) <- checkP tenv p y a' + let tenv' = (length binds, sigma ++ rho, binds ++ gamma) + ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) + return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt + _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ + [] -> do + (e,cs) <- checkExp th tenv t ty + return (([],e),cs) + checkP env@(k,rho,gamma) t x a = do + (delta,cs) <- checkPatt th env t a + let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] + return (VClos sigma t, sigma, delta, cs) + + ps2ts k = foldr p2t ([],0,[],k) + p2t p (ps,i,g,k) = case p of + PW -> (meta (MetaSymb i) : ps, i+1,g,k) + PV IW -> (meta (MetaSymb i) : ps, i+1,g,k) + PV x -> (vr x : ps, i, upd x k g,k+1) + PString s -> (K s : ps, i, g, k) + PInt n -> (EInt n : ps, i, g, k) + PFloat n -> (EFloat n : ps, i, g, k) + PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') + where (xss,j,g',k') = foldr p2t ([],i,g,k) xs + _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" + + upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables + + +checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)]) +checkPatt th tenv exp val = do + (aexp,_,cs) <- checkExpP tenv exp val + let binds = extrBinds aexp + return (binds,cs) + where + extrBinds aexp = case aexp of + AVr i v -> [(i,v)] + AApp f a _ -> extrBinds f ++ extrBinds a + _ -> [] -- no other cases are possible + +--- ad hoc, to find types of variables + checkExpP tenv@(k,rho,gamma) exp val = case exp of + Meta m -> return $ (AMeta m val, val, []) + Vr x -> return $ (AVr x val, val, []) + EInt i -> return (AInt i, valAbsInt, []) + EFloat i -> return (AFloat i, valAbsFloat, []) + K s -> return (AStr s, valAbsString, []) + + Q m c -> do + typ <- lookupConst th (m,c) + return $ (ACn (m,c) typ, typ, []) + QC m c -> do + typ <- lookupConst th (m,c) + return $ (ACn (m,c) typ, typ, []) ---- + App f t -> do + (f',w,csf) <- checkExpP tenv f val + typ <- whnf w + case typ of + VClos env (Prod x a b) -> do + (a',_,csa) <- checkExpP tenv t (VClos env a) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) + _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ + _ -> prtBad "cannot typecheck pattern" exp + +-- auxiliaries + +noConstr :: Err Val -> Err (Val,[(Val,Val)]) +noConstr er = er >>= (\v -> return (v,[])) + +mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) +mkAnnot a ti = do + (v,cs) <- ti + return (a v, v, cs) + diff --git a/src-3.0/GF/Grammar/TypeCheck.hs b/src-3.0/GF/Grammar/TypeCheck.hs new file mode 100644 index 000000000..97b7ff243 --- /dev/null +++ b/src-3.0/GF/Grammar/TypeCheck.hs @@ -0,0 +1,311 @@ +---------------------------------------------------------------------- +-- | +-- Module : TypeCheck +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/15 16:22:02 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.16 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Grammar.TypeCheck (-- * top-level type checking functions; TC should not be called directly. + annotate, annotateIn, + justTypeCheck, checkIfValidExp, + reduceConstraints, + splitConstraints, + possibleConstraints, + reduceConstraintsNode, + performMetaSubstNode, + -- * some top-level batch-mode checkers for the compiler + justTypeCheckSrc, + grammar2theorySrc, + checkContext, + checkTyp, + checkEquation, + checkConstrs, + editAsTermCommand, + exp2termCommand, + exp2termlistCommand, + tree2termlistCommand + ) where + +import GF.Data.Operations +import GF.Data.Zipper + +import GF.Grammar.Abstract +import GF.Grammar.AbsCompute +import GF.Grammar.Refresh +import GF.Grammar.LookAbs +import qualified GF.Grammar.Lookup as Lookup --- + +import GF.Grammar.TC + +import GF.Grammar.Unify --- + +import Control.Monad (foldM, liftM, liftM2) +import Data.List (nub) --- + +-- top-level type checking functions; TC should not be called directly. + +annotate :: GFCGrammar -> Exp -> Err Tree +annotate gr exp = annotateIn gr [] exp Nothing + +-- | type check in empty context, return a list of constraints +justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints +justTypeCheck gr e v = do + (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v + constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0 + return $ fst $ splitConstraints gr constrs1 + +-- | type check in empty context, return the expression itself if valid +checkIfValidExp :: GFCGrammar -> Exp -> Err Exp +checkIfValidExp gr e = do + (_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e + constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0 + ifNull (return e) (Bad . unwords . prConstrs) constrs1 + +annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree +annotateIn gr gamma exp = maybe (infer exp) (check exp) where + infer e = do + (a,_,cs) <- inferExp theory env e + aexp2treeC (a,cs) + check e v = do + (a,cs) <- checkExp theory env e v + aexp2treeC (a,cs) + env = initTCEnv gamma + theory = grammar2theory gr + aexp2treeC (a,c) = do + c' <- reduceConstraints (lookupAbsDef gr) (length gamma) c + aexp2tree (a,c') + +-- | invariant way of creating TCEnv from context +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) + +-- | process constraints after eqVal by computing by defs +reduceConstraints :: LookDef -> Int -> Constraints -> Err Constraints +reduceConstraints look i = liftM concat . mapM redOne where + redOne (u,v) = do + u' <- computeVal look u + v' <- computeVal look v + eqVal i u' v' + +computeVal :: LookDef -> Val -> Err Val +computeVal look v = case v of + VClos g@(_:_) e -> do + e' <- compt (map fst g) e --- bindings of g in e? + whnf $ VClos g e' +{- ---- + _ -> do ---- how to compute a Val, really?? + e <- val2exp v + e' <- compt [] e + whnf $ vClos e' +-} + VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf + _ -> whnf v + where + compt = computeAbsTermIn look + compv = computeVal look + +-- | take apart constraints that have the form (? <> t), usable as solutions +splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst) +splitConstraints gr = splitConstraintsGen (lookupAbsDef gr) + +splitConstraintsSrc :: Grammar -> Constraints -> (Constraints,MetaSubst) +splitConstraintsSrc gr = splitConstraintsGen (Lookup.lookupAbsDef gr) + +splitConstraintsGen :: LookDef -> Constraints -> (Constraints,MetaSubst) +splitConstraintsGen look cs = csmsu where + + csmsu = (nub [(a,b) | (a,b) <- csf1,a /= b],msf1) + (csf1,msf1) = unif (csf,msf) -- alternative: filter first + (csf,msf) = foldr mkOne ([],[]) cs + + csmsf = foldr mkOne ([],msu) csu + (csu,msu) = unif (cs1,[]) -- alternative: unify first + + cs1 = errVal cs $ reduceConstraints look 0 cs + + mkOne (u,v) = case (u,v) of + (VClos g (Meta m), v) | null g -> sub m v + (v, VClos g (Meta m)) | null g -> sub m v + -- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG + c -> con c + con c (cs,ms) = (c:cs,ms) + sub m v (cs,ms) = (cs,(m,v):ms) + + unifo = id -- alternative: don't use unification + + unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification + (cs',ms') <- unifyVal cs + return (cs', ms' ++ ms) + +performMetaSubstNode :: MetaSubst -> TrNode -> TrNode +performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let + v' = metaSubstVal v + b' = [(x,metaSubstVal v) | (x,v) <- b] + c' = [(u',v') | (u,v) <- c, + let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v'] + in N (b',a,v',(c',m),s) + where + metaSubstVal u = errVal u $ whnf $ case u of + VApp f a -> VApp (metaSubstVal f) (metaSubstVal a) + VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e) + _ -> u + metaSubstExp e = case e of + Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst + _ -> composSafeOp metaSubstExp e + +reduceConstraintsNode :: GFCGrammar -> TrNode -> TrNode +reduceConstraintsNode gr = changeConstrs red where + red cs = errVal cs $ reduceConstraints (lookupAbsDef gr) 0 cs + +-- | weak heuristic to narrow down menus; not used for TC. 15\/11\/2001. +-- the age-old method from GF 0.9 +possibleConstraints :: GFCGrammar -> Constraints -> Bool +possibleConstraints gr = and . map (possibleConstraint gr) + +possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool +possibleConstraint gr (u,v) = errVal True $ do + u' <- val2exp u >>= compute gr + v' <- val2exp v >>= compute gr + return $ cts u' v' + where + cts t u = isUnknown t || isUnknown u || case (t,u) of + (Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d) + (QC m c, QC n d) -> c == d + (App f a, App g b) -> cts f g && cts a b + (Abs x b, Abs y c) -> cts b c + (Prod x a f, Prod y b g) -> cts a b && cts f g + (_ , _) -> False + + isUnknown t = case t of + Vr _ -> True + Meta _ -> True + _ -> False + + notCan = not . isPrimitiveFun gr + +-- interface to TC type checker + +type2val :: Type -> Val +type2val = VClos [] + +aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree +aexp2tree (aexp,cs) = do + (bi,at,vt,ts) <- treeForm aexp + ts' <- mapM aexp2tree [(t,[]) | t <- ts] + return $ Tr (N (bi,at,vt,(cs,[]),False),ts') + where + treeForm a = case a of + AAbs x v b -> do + (bi, at, vt, args) <- treeForm b + v' <- whnf v ---- should not be needed... + return ((x,v') : bi, at, vt, args) + AApp c a v -> do + (_,at,_,args) <- treeForm c + v' <- whnf v ---- + return ([],at,v',args ++ [a]) + AVr x v -> do + v' <- whnf v ---- + return ([],AtV x,v',[]) + ACn c v -> do + v' <- whnf v ---- + return ([],AtC c,v',[]) + AInt i -> do + return ([],AtI i,valAbsInt,[]) + AFloat i -> do + return ([],AtF i,valAbsFloat,[]) + AStr s -> do + return ([],AtL s,valAbsString,[]) + AMeta m v -> do + v' <- whnf v ---- + return ([],AtM m,v',[]) + _ -> Bad "illegal tree" -- AProd + +grammar2theory :: GFCGrammar -> Theory +grammar2theory gr (m,f) = case lookupFunType gr m f of + Ok t -> return $ type2val t + Bad s -> case lookupCatContext gr m f of + Ok cont -> return $ cont2val cont + _ -> Bad s + +cont2exp :: Context -> Exp +cont2exp c = mkProd (c, eType, []) -- to check a context + +cont2val :: Context -> Val +cont2val = type2val . cont2exp + +-- some top-level batch-mode checkers for the compiler + +justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints +justTypeCheckSrc gr e v = do + (_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v + return $ filter notJustMeta constrs0 +---- return $ fst $ splitConstraintsSrc gr constrs0 +---- this change was to force proper tc of abstract modules. +---- May not be quite right. AR 13/9/2005 + +notJustMeta (c,k) = case (c,k) of + (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False + _ -> True + +grammar2theorySrc :: Grammar -> Theory +grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of + Ok t -> return $ type2val t + Bad s -> case lookupCatContextSrc gr m f of + Ok cont -> return $ cont2val cont + _ -> Bad s + +checkContext :: Grammar -> Context -> [String] +checkContext st = checkTyp st . cont2exp + +checkTyp :: Grammar -> Type -> [String] +checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType + +checkEquation :: Grammar -> Fun -> Trm -> [String] +checkEquation gr (m,fun) def = err singleton id $ do + typ <- lookupFunTypeSrc gr m fun +---- cs <- checkEqs (grammar2theorySrc gr) (initTCEnv []) ((m,fun),def) (vClos typ) + cs <- justTypeCheckSrc gr def (vClos typ) + let cs1 = filter notJustMeta cs ----- filter (not . possibleConstraint gr) cs ---- + return $ ifNull [] (singleton . prConstraints) cs1 + +checkConstrs :: Grammar -> Cat -> [Ident] -> [String] +checkConstrs gr cat _ = [] ---- check constructors! + + + + + + +{- ---- +err singleton concat . mapM checkOne where + checkOne con = do + typ <- lookupFunType gr con + typ' <- computeAbsTerm gr typ + vcat <- valCat typ' + return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con] +-} + +editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp] +editAsTermCommand gr c e = err (const []) singleton $ do + t <- annotate gr $ refreshMetas [] e + t' <- c $ tree2loc t + return $ tree2exp $ loc2tree t' + +exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree +exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do + let exp = tree2exp t + exp2 <- f exp + annotate gr exp2 + +exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree] +exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp + +tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree] +tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f diff --git a/src-3.0/GF/Grammar/Unify.hs b/src-3.0/GF/Grammar/Unify.hs new file mode 100644 index 000000000..588c1b306 --- /dev/null +++ b/src-3.0/GF/Grammar/Unify.hs @@ -0,0 +1,96 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Grammar/Values.hs b/src-3.0/GF/Grammar/Values.hs new file mode 100644 index 000000000..6e029d98b --- /dev/null +++ b/src-3.0/GF/Grammar/Values.hs @@ -0,0 +1,109 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/IDE/IDECommands.hs b/src-3.0/GF/IDE/IDECommands.hs new file mode 100644 index 000000000..56d392a71 --- /dev/null +++ b/src-3.0/GF/IDE/IDECommands.hs @@ -0,0 +1,95 @@ +---------------------------------------------------------------------- +-- | +-- Module : IDECommands +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:41 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.2 $ +-- +-- Commands usable in grammar-writing IDE. +----------------------------------------------------------------------------- + +module GF.IDE.IDECommands where + +import GF.Infra.Ident (Ident, identC) +import GF.Compile.ShellState +import qualified GF.Shell.ShellCommands as S +import qualified GF.Shell.Commands as E +import qualified GF.Shell.CommandL as PE +import GF.UseGrammar.Session +import GF.UseGrammar.Custom +import GF.Grammar.PrGrammar + +import GF.Infra.Option +import GF.Data.Operations +import GF.Infra.Modules +import GF.Infra.UseIO + +data IDEState = IDE { + ideShellState :: ShellState, + ideAbstract :: Maybe Ident, + ideConcretes :: [Ident], + ideCurrentCnc :: Maybe Ident, + ideCurrentLin :: Maybe Ident, -- lin or lincat + ideSState :: Maybe SState + } + +emptyIDEState :: ShellState -> IDEState +emptyIDEState shst = IDE shst Nothing [] Nothing Nothing Nothing + +data IDECommand = + IDEInit + | IDEAbstract Ident + | IDEConcrete Ident + | IDELin Ident + | IDEShell String -- S.Command + | IDEEdit String -- E.Command + | IDEQuit + | IDEVoid String -- the given command itself maybe + + +execIDECommand :: IDECommand -> IDEState -> IOE IDEState +execIDECommand c state = case c of + IDEInit -> + return $ emptyIDEState env + IDEAbstract a -> + return $ state {ideAbstract = Just a} ---- check a exists or import it + IDEConcrete a -> + return $ state {ideCurrentCnc = Just a} ---- check a exists or import it + IDELin a -> + return $ state {ideCurrentLin = Just a} ---- check a exists + IDEEdit s -> + execEdit s + IDEShell s -> + execShell s + IDEVoid s -> ioeErr $ fail s + _ -> ioeErr $ fail "command not implemented" + + where + env = ideShellState state + sstate = maybe initSState id $ ideSState state + + execShell s = execEdit $ "gf" +++ s + + execEdit s = ioeIO $ do + (env',sstate') <- E.execCommand env (PE.pCommand s) sstate + return $ state {ideShellState = env', ideSState = Just sstate'} + + putMsg = putStrLn ---- XML + +pCommands :: String -> [IDECommand] +pCommands = map pCommand . concatMap (chunks ";;" . words) . lines + +pCommand :: [String] -> IDECommand +pCommand ws = case ws of + "gf" : s -> IDEShell $ unwords s + "edit" : s -> IDEEdit $ unwords s + "abstract" : a : _ -> IDEAbstract $ identC a + "concrete" : a : _ -> IDEConcrete $ identC a + "lin" : a : _ -> IDELin $ identC a + "empty" : _ -> IDEInit + "quit" : _ -> IDEQuit + _ -> IDEVoid $ unwords ws diff --git a/src-3.0/GF/Infra/CheckM.hs b/src-3.0/GF/Infra/CheckM.hs new file mode 100644 index 000000000..251ed2b8b --- /dev/null +++ b/src-3.0/GF/Infra/CheckM.hs @@ -0,0 +1,89 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Infra/Comments.hs b/src-3.0/GF/Infra/Comments.hs new file mode 100644 index 000000000..0126db468 --- /dev/null +++ b/src-3.0/GF/Infra/Comments.hs @@ -0,0 +1,43 @@ +---------------------------------------------------------------------- +-- | +-- Module : Comments +-- Maintainer : (Maintainer) +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:34 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.5 $ +-- +-- comment removal +----------------------------------------------------------------------------- + +module GF.Infra.Comments ( remComments + ) where + +-- | comment removal : line tails prefixed by -- as well as chunks in @{- ... -}@ +remComments :: String -> String +remComments s = + case s of + '"':s2 -> '"':pass remComments s2 -- comment marks in quotes not removed! + '{':'-':cs -> readNested cs + '-':'-':cs -> readTail cs + c:cs -> c : remComments cs + [] -> [] + where + readNested t = + case t of + '"':s2 -> '"':pass readNested s2 + '-':'}':cs -> remComments cs + _:cs -> readNested cs + [] -> [] + readTail t = + case t of + '\n':cs -> '\n':remComments cs + _:cs -> readTail cs + [] -> [] + pass f t = + case t of + '"':s2 -> '"': f s2 + c:s2 -> c:pass f s2 + _ -> t diff --git a/src-3.0/GF/Infra/CompactPrint.hs b/src-3.0/GF/Infra/CompactPrint.hs new file mode 100644 index 000000000..486c9e183 --- /dev/null +++ b/src-3.0/GF/Infra/CompactPrint.hs @@ -0,0 +1,22 @@ +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-3.0/GF/Infra/Ident.hs b/src-3.0/GF/Infra/Ident.hs new file mode 100644 index 000000000..5ed860990 --- /dev/null +++ b/src-3.0/GF/Infra/Ident.hs @@ -0,0 +1,155 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Infra/Modules.hs b/src-3.0/GF/Infra/Modules.hs new file mode 100644 index 000000000..4d50608c6 --- /dev/null +++ b/src-3.0/GF/Infra/Modules.hs @@ -0,0 +1,416 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Infra/Option.hs b/src-3.0/GF/Infra/Option.hs new file mode 100644 index 000000000..a44cd9db8 --- /dev/null +++ b/src-3.0/GF/Infra/Option.hs @@ -0,0 +1,375 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Infra/Print.hs b/src-3.0/GF/Infra/Print.hs new file mode 100644 index 000000000..17f2c2188 --- /dev/null +++ b/src-3.0/GF/Infra/Print.hs @@ -0,0 +1,127 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:18 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- Pretty-printing +----------------------------------------------------------------------------- + +module GF.Infra.Print + (module GF.Infra.PrintClass + ) where + +-- haskell modules: +import Data.Char (toUpper) +-- gf modules: + +import GF.Infra.PrintClass +import GF.Data.Operations (Err(..)) +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +import GF.CF.CF +import GF.CF.CFIdent +import qualified GF.Canon.PrintGFC as P + +------------------------------------------------------------ + +---------------------------------------------------------------------- + +instance Print Ident where + prt = P.printTree + +instance Print Term where + prt (Arg arg) = prt arg + prt (con `Par` []) = prt con + prt (con `Par` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")" + prt (LI ident) = "$" ++ prt ident + prt (R record) = "{" ++ prtSep "; " record ++ "}" + prt (term `P` lbl) = prt term ++ "." ++ prt lbl + prt (T _ table) = "table{" ++ prtSep "; " table ++ "}" + prt (V _ terms) = "values{" ++ prtSep "; " terms ++ "}" + prt (term `S` sel) = "(" ++ prt term ++ " ! " ++ prt sel ++ ")" + prt (FV terms) = "variants{" ++ prtSep " | " terms ++ "}" + prt (term `C` term') = prt term ++ " " ++ prt term' + prt (EInt n) = prt n + prt (K tokn) = show (prt tokn) + prt (E) = show "" + +instance Print Patt where + prt (con `PC` []) = prt con + prt (con `PC` pats) = prt con ++ "(" ++ prtSep "," pats ++ ")" + prt (PV ident) = "$" ++ prt ident + prt (PW) = "_" + prt (PR record) = "{" ++ prtSep ";" record ++ "}" + +instance Print Label where + prt (L ident) = prt ident + prt (LV nr) = "$" ++ show nr + +instance Print Tokn where + prt (KS str) = str + prt tokn@(KP _ _) = show tokn + +instance Print ArgVar where + prt (A cat argNr) = prt cat ++ "#" ++ show argNr + +instance Print CIdent where + prt (CIQ _ ident) = prt ident + +instance Print Case where + prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term + +instance Print Assign where + prt (lbl `Ass` term) = prt lbl ++ "=" ++ prt term + +instance Print PattAssign where + prt (lbl `PAss` pat) = prt lbl ++ "=" ++ prt pat + +instance Print Atom where + prt (AC c) = prt c + prt (AD c) = "<" ++ prt c ++ ">" + prt (AV i) = "$" ++ prt i + prt (AM n) = "?" ++ show n + prt atom = show atom + +instance Print CType where + prt (RecType rtype) = "{" ++ prtSep "; " rtype ++ "}" + prt (Table ptype vtype) = "(" ++ prt ptype ++ " => " ++ prt vtype ++ ")" + prt (Cn cn) = prt cn + prt (TStr) = "Str" + +instance Print Labelling where + prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype + +instance Print CFItem where + prt (CFTerm regexp) = prt regexp + prt (CFNonterm cat) = prt cat + +instance Print RegExp where + prt (RegAlts words) = "("++prtSep "|" words ++ ")" + prt (RegSpec tok) = prt tok + +instance Print CFTok where + prt (TS str) = str + prt (TC (c:str)) = '(' : toUpper c : ')' : str + prt (TL str) = show str + prt (TI n) = "#" ++ show n + prt (TV x) = "$" ++ prt x + prt (TM n s) = "?" ++ show n ++ s + +instance Print CFCat where + prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl + +instance Print CFFun where + prt (CFFun fun) = prt (fst fun) + +instance Print Exp where + prt = P.printTree + +instance Print a => Print (Err a) where + prt (Ok a) = prt a + prt (Bad str) = str + diff --git a/src-3.0/GF/Infra/PrintClass.hs b/src-3.0/GF/Infra/PrintClass.hs new file mode 100644 index 000000000..5e94984a6 --- /dev/null +++ b/src-3.0/GF/Infra/PrintClass.hs @@ -0,0 +1,51 @@ +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-3.0/GF/Infra/ReadFiles.hs b/src-3.0/GF/Infra/ReadFiles.hs new file mode 100644 index 000000000..ce33ec23f --- /dev/null +++ b/src-3.0/GF/Infra/ReadFiles.hs @@ -0,0 +1,362 @@ +---------------------------------------------------------------------- +-- | +-- Module : ReadFiles +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.26 $ +-- +-- Decide what files to read as function of dependencies and time stamps. +-- +-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 +-- +-- to find all files that have to be read, put them in dependency order, and +-- decide which files need recompilation. Name @file.gf@ is returned for them, +-- and @file.gfc@ or @file.gfr@ otherwise. +----------------------------------------------------------------------------- + +module GF.Infra.ReadFiles (-- * Heading 1 + getAllFiles,fixNewlines,ModName,getOptionsFromFile, + -- * Heading 2 + gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile + ) where + +import GF.System.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime) + +import GF.Infra.Option +import GF.Data.Operations +import GF.Infra.UseIO + +import System +import Data.Char +import Control.Monad +import Data.List +import System.Directory +import System.FilePath + +type ModName = String +type ModEnv = [(ModName,ModTime)] + +getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] +getAllFiles opts ps env file = do + + -- read module headers from all files recursively + ds0 <- getImports ps file + let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] + if oElem beVerbose opts + then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) + else return () + -- get a topological sorting of files: returns file names --- deletes paths + ds1 <- ioeErr $ either + return + (\ms -> Bad $ "circular modules" +++ + unwords (map show (head ms))) $ topoTest $ map fst ds + + -- associate each file name with its path --- more optimal: save paths in ds1 + let paths = [(f,p) | ((f,_),p) <- ds] + let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] + if oElem fromSource opts + then return [gfFile (p f) | (p,f) <- pds1] + else do + + + ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 + + let ds4 = needCompile opts (map fst ds0) ds2 + return ds4 + +-- to decide whether to read gf or gfc, or if in env; returns full file path + +data CompStatus = + CSComp -- compile: read gf + | CSRead -- read gfc + | CSEnv -- gfc is in env + | CSEnvR -- also gfr is in env + | CSDont -- don't read at all + | CSRes -- read gfr + deriving (Eq,Show) + +-- for gfc, we also return ModTime to cope with earlier compilation of libs + +selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> + IO (ModName,(InitPath,(CompStatus,Maybe ModTime))) + +selectFormat opts env (p,f) = do + let pf = p f + let mtenv = lookup f env -- Nothing if f is not in env + let rtenv = lookup (resModName f) env + let fromComp = oElem isCompiled opts -- i -gfc + mtgfc <- getModTime $ gfcFile pf + mtgf <- getModTime $ gfFile pf + let stat = case (rtenv,mtenv,mtgfc,mtgf) of +-- (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) + (_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc) +-- (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv) +-- (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv) + (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> + case mtenv of +-- Just tenv | laterModTime tenv tgfc -> (CSEnv,Just tenv) + _ -> (CSRead,Just tgfc) + + +-- (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist + (_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist + _ -> (CSComp,Nothing) + return $ (f, (p,stat)) + +needCompile :: Options -> + [ModuleHeader] -> + [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath] +needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where + + deps = [(snd m,map fst ms) | (m,ms) <- headers] + typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers] + uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m] + stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0 + + allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where + add os = [m | o <- os, Just n <- [lookup o deps],m <- n] + + -- only treat reused, interface, or instantiation if needed + sfiles = sfiles0 ---- map relevant sfiles0 + relevant fp@(f,(p,(st,_))) = + let us = uses f + isUsed = not (null us) + in + if not (isUsed && all noComp us) then + fp else + if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource] + || + (isUsed && all isAux us)) then + (f,(p,(CSDont,Nothing))) else + fp + + isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd + noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst + + -- mark as to be compiled those whose gfc is earlier than a deeper gfc + sfiles1 = map compTimes sfiles + compTimes fp@(f,(p,(_, Just t))) = + if any (> t) [t' | Just fs <- [lookup f deps], + f0 <- fs, + Just (_,(_,Just t')) <- [lookup f0 sfiles]] + then (f,(p,(CSComp, Nothing))) + else fp + compTimes fp = fp + + -- start with the changed files themselves; returns [ModName] + changed = [f | (f,(_,(CSComp,_))) <- sfiles1] + + -- add other files that depend on some changed file; returns [ModName] + iter np = let new = [f | (f,fs) <- deps, + not (elem f np), any (flip elem np) fs] + in if null new then np else (iter (new ++ np)) + + -- for each module in the full list, compile if depends on what needs compile + -- returns [FullPath] + mark cs = [(f,(path,st)) | + (f,(path,(st0,_))) <- sfiles1, + let st = if (elem f cs) then CSComp else st0] + + + -- if a compilable file depends on a resource, read gfr instead of gfc/env + -- but don't read gfr if already in env (by CSEnvR) + -- Also read res if the option "retain" is present + -- Also, if a "with" file has to be compiled, read its mother file from source + + res cs = map mkRes cs where + mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of + t | (not (null [m | (m,(_,CSComp)) <- cs, + Just ms <- [lookup m allDeps], elem f ms]) + || oElem retainOpers opts) + -> if elem t [MTyResource,MTyIncResource] + then (f,(path,CSRes)) else + if t == MTyIncomplete + then (f,(path,CSComp)) else + x + _ -> x + mkRes x = x + + + + -- construct list of paths to read + paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]] + + mkName f p st = mk (p f) where + mk = case st of + CSComp -> gfFile + CSRead -> gfcFile + CSRes -> gfrFile + +isGFC :: FilePath -> Bool +isGFC = (== ".gfc") . takeExtensions + +gfcFile :: FilePath -> FilePath +gfcFile f = addExtension f "gfc" + +gfrFile :: FilePath -> FilePath +gfrFile f = addExtension f "gfr" + +gfFile :: FilePath -> FilePath +gfFile f = addExtension f "gf" + +resModName :: ModName -> ModName +resModName = ('#':) + +-- to get imports without parsing the whole files + +getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)] +getImports ps = get [] where + get ds file0 = do + let name = dropExtension file0 ---- dropExtension file0 + (p,s) <- tryRead name + let ((typ,mname),imps) = importsOfFile s + let namebody = takeFileName name + ioeErr $ testErr (mname == namebody) $ + "module name" +++ mname +++ "differs from file name" +++ namebody + case imps of + _ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read + [] -> return $ (((typ,name),[]),p):ds + _ -> do + let files = map (gfFile . fst) imps + foldM get ((((typ,name),imps),p):ds) files + tryRead name = do + file <- do + let file_gf = gfFile name + b <- doesFileExistPath ps file_gf -- try gf file first + if b then return file_gf else do + let file_gfr = gfrFile name + bb <- doesFileExistPath ps file_gfr -- gfr file next + if bb then return file_gfr else do + return (gfcFile name) -- gfc next + + readFileIfPath ps $ file + + + +-- internal module dep information + +data ModUse = + MUReuse + | MUInstance + | MUComplete + | MUOther + deriving (Eq,Show) + +data ModTyp = + MTyResource + | MTyIncomplete + | MTyIncResource -- interface, incomplete resource + | MTyOther + deriving (Eq,Show) + +type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) + +importsOfFile :: String -> ModuleHeader +importsOfFile = + getModuleHeader . -- analyse into mod header + filter (not . spec) . -- ignore keywords and special symbols + unqual . -- take away qualifiers + unrestr . -- take away union restrictions + takeWhile (not . term) . -- read until curly or semic + lexs . -- analyse into lexical tokens + unComm -- ignore comments before the headed line + where + term = flip elem ["{",";"] + spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"] + unqual ws = case ws of + "(":q:ws' -> unqual ws' + w:ws' -> w:unqual ws' + _ -> ws + unrestr ws = case ws of + "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws' + w:ws' -> w:unrestr ws' + _ -> ws + +getModuleHeader :: [String] -> ModuleHeader -- with, reuse +getModuleHeader ws = case ws of + "incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in + case ty of + MTyResource -> ((MTyIncResource,name),us) + _ -> ((MTyIncomplete,name),us) + "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in + ((MTyIncResource,name),us) + + "resource":name:ws2 -> case ws2 of + "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)]) + m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + ms -> ((MTyResource,name),[(n,MUOther) | n <- ms]) + + "instance":name:m:ws2 -> case ws2 of + "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)]) + n:"with":ms -> + ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms]) + ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms]) + + "concrete":name:a:ws2 -> case span (/= "with") ws2 of + + (es,_:ms) -> ((MTyOther,name), + [(m,MUOther) | m <- es] ++ + [(n,MUComplete) | n <- ms]) + --- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + (ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms]) + + _:name:ws2 -> case ws2 of + "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)]) + ---- m:n:"with":ms -> + ---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms]) + m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + ms -> ((MTyOther,name),[(n,MUOther) | n <- ms]) + _ -> error "the file is empty" + +unComm s = case s of + '-':'-':cs -> unComm $ dropWhile (/='\n') cs + '{':'-':cs -> dpComm cs + c:cs -> c : unComm cs + _ -> s + +dpComm s = case s of + '-':'}':cs -> unComm cs + c:cs -> dpComm cs + _ -> s + +lexs s = x:xs where + (x,y) = head $ lex s + xs = if null y then [] else lexs y + +-- | options can be passed to the compiler by comments in @--#@, in the main file +getOptionsFromFile :: FilePath -> IO Options +getOptionsFromFile file = do + s <- readFileIfStrict file + let ls = filter (isPrefixOf "--#") $ lines s + return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls + +-- | check if old GF file +isOldFile :: FilePath -> IO Bool +isOldFile f = do + s <- readFileIfStrict f + let s' = unComm s + return $ not (null s') && old (head (words s')) + where + old = flip elem $ words + "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule" + + + +-- | old GF tolerated newlines in quotes. No more supported! +fixNewlines :: String -> String +fixNewlines s = case s of + '"':cs -> '"':mk cs + c :cs -> c:fixNewlines cs + _ -> s + where + mk s = case s of + '\\':'"':cs -> '\\':'"': mk cs + '"' :cs -> '"' :fixNewlines cs + '\n' :cs -> '\\':'n': mk cs + c :cs -> c : mk cs + _ -> s + diff --git a/src-3.0/GF/Infra/UseIO.hs b/src-3.0/GF/Infra/UseIO.hs new file mode 100644 index 000000000..4125a0417 --- /dev/null +++ b/src-3.0/GF/Infra/UseIO.hs @@ -0,0 +1,330 @@ +{-# OPTIONS -cpp #-} +---------------------------------------------------------------------- +-- | +-- Module : UseIO +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.17 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Infra.UseIO where + +import GF.Data.Operations +import GF.System.Arch (prCPU) +import GF.Infra.Option +import GF.Today (libdir) + +import System.Directory +import System.IO +import System.IO.Error +import System.Environment +import System.FilePath +import Control.Monad + +#ifdef mingw32_HOST_OS +import System.Win32.DLL +import Foreign.Ptr +#endif + + +putShow' :: Show a => (c -> a) -> c -> IO () +putShow' f = putStrLn . show . length . show . f + +putIfVerb :: Options -> String -> IO () +putIfVerb opts msg = + if oElem beVerbose opts + then putStrLn msg + else return () + +putIfVerbW :: Options -> String -> IO () +putIfVerbW opts msg = + if oElem beVerbose opts + then putStr (' ' : msg) + else return () + +-- | obsolete with IOE monad +errIO :: a -> Err a -> IO a +errIO = errOptIO noOptions + +errOptIO :: Options -> a -> Err a -> IO a +errOptIO os e m = case m of + Ok x -> return x + Bad k -> do + putIfVerb os k + return e + +prOptCPU :: Options -> Integer -> IO Integer +prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU + +putCPU :: IO () +putCPU = do + prCPU 0 + return () + +putPoint :: Show a => Options -> String -> IO a -> IO a +putPoint = putPoint' id + +putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c +putPoint' f opts msg act = do + let sil x = if oElem beSilent opts then return () else x + ve x = if oElem beVerbose opts then x else return () + ve $ putStrLn msg + a <- act + ve $ putShow' f a + ve $ putCPU + return a + +readFileStrict :: String -> IO String +readFileStrict f = do + s <- readFile f + return $ seq (length s) () + return s + +readFileIf = readFileIfs readFile +readFileIfStrict = readFileIfs readFileStrict + +readFileIfs rf f = catch (rf f) (\_ -> reportOn f) where + reportOn f = do + putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") + return "" + +type FileName = String +type InitPath = String +type FullPath = String + +getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) +getFilePath ps file = do + getFilePathMsg ("file" +++ file +++ "not found\n") ps file + +getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath) +getFilePathMsg msg paths file = get paths where + get [] = putStrFlush msg >> return Nothing + get (p:ps) = do + let pfile = p file + exist <- doesFileExist pfile + if exist then return (Just pfile) else get ps +--- catch (readFileStrict pfile >> return (Just pfile)) (\_ -> get ps) + +readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String) +readFileIfPath paths file = do + mpfile <- ioeIO $ getFilePath paths file + case mpfile of + Just pfile -> do + s <- ioeIO $ readFileStrict pfile + return (dropFileName pfile,s) + _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") + +doesFileExistPath :: [FilePath] -> String -> IOE Bool +doesFileExistPath paths file = do + mpfile <- ioeIO $ getFilePathMsg "" paths file + return $ maybe False (const True) mpfile + +gfLibraryPath = "GF_LIB_PATH" + +-- | environment variable for grammar search path +gfGrammarPathVar = "GF_GRAMMAR_PATH" + +getLibraryPath :: IO FilePath +getLibraryPath = + catch + (getEnv gfLibraryPath) +#ifdef mingw32_HOST_OS + (\_ -> do exepath <- getModuleFileName nullPtr + let (path,_) = splitFileName exepath + canonicalizePath (combine path "../lib")) +#else + (const (return libdir)) +#endif + +-- | extends the search path with the +-- 'gfLibraryPath' and 'gfGrammarPathVar' +-- environment variables. Returns only existing paths. +extendPathEnv :: [FilePath] -> IO [FilePath] +extendPathEnv ps = do + b <- getLibraryPath -- e.g. GF_LIB_PATH + s <- catch (getEnv gfGrammarPathVar) (const (return "")) -- e.g. GF_GRAMMAR_PATH + let ss = ps ++ splitSearchPath s + liftM concat $ mapM allSubdirs $ ss ++ [b s | s <- ss ++ ["prelude"]] + where + allSubdirs :: FilePath -> IO [FilePath] + allSubdirs [] = return [[]] + allSubdirs p = case last p of + '*' -> do let path = init p + fs <- getSubdirs path + return [path f | f <- fs] + _ -> do exists <- doesDirectoryExist p + if exists + then return [p] + else return [] + +getSubdirs :: FilePath -> IO [FilePath] +getSubdirs dir = do + fs <- catch (getDirectoryContents dir) (const $ return []) + foldM (\fs f -> do let fpath = dir f + p <- getPermissions fpath + if searchable p && not (take 1 f==".") + then return (fpath:fs) + else return fs ) [] fs + +justModuleName :: FilePath -> String +justModuleName = dropExtension . takeFileName + +splitInModuleSearchPath :: String -> [FilePath] +splitInModuleSearchPath s = case break isPathSep s of + (f,_:cs) -> f : splitInModuleSearchPath cs + (f,_) -> [f] + where + isPathSep :: Char -> Bool + isPathSep c = c == ':' || c == ';' + +-- + +getLineWell :: IO String -> IO String +getLineWell ios = + catch getLine (\e -> if (isEOFError e) then ios else ioError e) + +putStrFlush :: String -> IO () +putStrFlush s = putStr s >> hFlush stdout + +putStrLnFlush :: String -> IO () +putStrLnFlush s = putStrLn s >> hFlush stdout + +-- * a generic quiz session + +type QuestionsAndAnswers = [(String, String -> (Integer,String))] + +teachDialogue :: QuestionsAndAnswers -> String -> IO () +teachDialogue qas welc = do + putStrLn $ welc ++++ genericTeachWelcome + teach (0,0) qas + where + teach _ [] = do putStrLn "Sorry, ran out of problems" + teach (score,total) ((question,grade):quas) = do + putStr ("\n" ++ question ++ "\n> ") + answer <- getLine + if (answer == ".") then return () else do + let (result, feedback) = grade answer + score' = score + result + total' = total + 1 + putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total') + if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75) + then do putStrLn "\nCongratulations - you passed!" + else teach (score',total') quas + + genericTeachWelcome = + "The quiz is over when you have done at least 10 examples" ++++ + "with at least 75 % success." +++++ + "You can interrupt the quiz by entering a line consisting of a dot ('.').\n" + + +-- * IO monad with error; adapted from state monad + +newtype IOE a = IOE (IO (Err a)) + +appIOE :: IOE a -> IO (Err a) +appIOE (IOE iea) = iea + +ioe :: IO (Err a) -> IOE a +ioe = IOE + +ioeIO :: IO a -> IOE a +ioeIO io = ioe (io >>= return . return) + +ioeErr :: Err a -> IOE a +ioeErr = ioe . return + +instance Monad IOE where + return a = ioe (return (return a)) + IOE c >>= f = IOE $ do + x <- c -- Err a + appIOE $ err ioeBad f x -- f :: a -> IOE a + +ioeBad :: String -> IOE a +ioeBad = ioe . return . Bad + +useIOE :: a -> IOE a -> IO a +useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return + +foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) +foldIOE f s xs = case xs of + [] -> return (s,Nothing) + x:xx -> do + ev <- ioeIO $ appIOE (f s x) + case ev of + Ok v -> foldIOE f v xx + Bad m -> return $ (s, Just m) + +putStrLnE :: String -> IOE () +putStrLnE = ioeIO . putStrLnFlush + +putStrE :: String -> IOE () +putStrE = ioeIO . putStrFlush + +-- this is more verbose +putPointE :: Options -> String -> IOE a -> IOE a +putPointE = putPointEgen (oElem beSilent) + +-- this is less verbose +putPointEsil :: Options -> String -> IOE a -> IOE a +putPointEsil = putPointEgen (not . oElem beVerbose) + +putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a +putPointEgen cond opts msg act = do + let ve x = if cond opts then return () else x + ve $ ioeIO $ putStrFlush msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putStrFlush " " + ve $ ioeIO $ putCPU + return a +{- +putPointE :: Options -> String -> IOE a -> IOE a +putPointE opts msg act = do + let ve x = if oElem beVerbose opts then x else return () + ve $ putStrE msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putCPU + return a +-} + +-- | forces verbosity +putPointEVerb :: Options -> String -> IOE a -> IOE a +putPointEVerb opts = putPointE (addOption beVerbose opts) + +-- ((do {s <- readFile f; return (return s)}) ) +readFileIOE :: FilePath -> IOE (String) +readFileIOE f = ioe $ catch (readFileStrict f >>= return . return) + (\e -> return (Bad (show e))) + +-- | like readFileIOE but look also in the GF library if file not found +-- +-- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@ +-- (even if file is an absolute path, but this should always fail) +-- it returns not only contents of the file, but also the path used +readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String) +readFileLibraryIOE ini f = ioe $ do + lp <- getLibraryPath + tryRead ini $ \_ -> + tryRead lp $ \e -> + return (Bad (show e)) + where + tryRead path onError = + catch (readFileStrict fpath >>= \s -> return (return (fpath,s))) + onError + where + fpath = path f + +-- | example +koeIOE :: IO () +koeIOE = useIOE () $ do + s <- ioeIO $ getLine + s2 <- ioeErr $ mapM (!? 2) $ words s + ioeIO $ putStrLn s2 + diff --git a/src-3.0/GF/JavaScript/AbsJS.hs b/src-3.0/GF/JavaScript/AbsJS.hs new file mode 100644 index 000000000..2632ade48 --- /dev/null +++ b/src-3.0/GF/JavaScript/AbsJS.hs @@ -0,0 +1,60 @@ +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-3.0/GF/JavaScript/JS.cf b/src-3.0/GF/JavaScript/JS.cf new file mode 100644 index 000000000..fe31a2074 --- /dev/null +++ b/src-3.0/GF/JavaScript/JS.cf @@ -0,0 +1,55 @@ +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-3.0/GF/JavaScript/LexJS.hs b/src-3.0/GF/JavaScript/LexJS.hs new file mode 100644 index 000000000..242831195 --- /dev/null +++ b/src-3.0/GF/JavaScript/LexJS.hs @@ -0,0 +1,337 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 3 "LexJS.x" #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module GF.JavaScript.LexJS where + + + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#else +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\x6d\x01\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x03\x00\xff\xff\x03\x00\xff\xff\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x02\x00\x0b\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x03\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x06\x00\x00\x00\x00\x00\xff\xff\x04\x00\x06\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\xff\xff\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x07\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x0c\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,13) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]] +{-# LINE 32 "LexJS.x" #-} + +tok f p s = f p s + +share :: String -> String +share = id + +data Tok = + TS !String -- reserved words and symbols + | TL !String -- string literals + | TI !String -- integer literals + | TV !String -- identifiers + | TD !String -- double precision float literals + | TC !String -- character literals + + deriving (Eq,Show,Ord) + +data Token = + PT Posn Tok + | Err Posn + deriving (Eq,Show,Ord) + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +posLineCol (Pn _ l c) = (l,c) +mkPosToken t@(PT p _) = (posLineCol p, prToken t) + +prToken t = case t of + PT _ (TS s) -> s + PT _ (TI s) -> s + PT _ (TV s) -> s + PT _ (TD s) -> s + PT _ (TC s) -> s + + _ -> show t + +data BTree = N | B String Tok BTree BTree deriving (Show) + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = treeFind resWords + where + treeFind N = tv s + treeFind (B a t left right) | s < a = treeFind left + | s > a = treeFind right + | s == a = t + +resWords = b "return" (b "new" (b "function" (b "false" N N) N) (b "null" N N)) (b "true" (b "this" N N) (b "var" N N)) + where b s = B s (TS s) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn !Int !Int !Int + deriving (Eq, Show,Ord) + +alexStartPos :: Posn +alexStartPos = Pn 0 1 1 + +alexMove :: Posn -> Char -> Posn +alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 +alexMove (Pn a l c) _ = Pn (a+1) l (c+1) + +type AlexInput = (Posn, -- current position, + Char, -- previous char + String) -- current input string + +tokens :: String -> [Token] +tokens str = go (alexStartPos, '\n', str) + where + go :: (Posn, Char, String) -> [Token] + go inp@(pos, _, str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError (pos, _, _) -> [Err pos] + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : (go inp') + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p, c, []) = Nothing +alexGetChar (p, _, (c:s)) = + let p' = alexMove p c + in p' `seq` Just (c, (p', c, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, s) = c + +alex_action_1 = tok (\p s -> PT p (TS $ share s)) +alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_3 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) +alex_action_4 = tok (\p s -> PT p (TI $ share s)) +alex_action_5 = tok (\p s -> PT p (TD $ share s)) +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 35 "GenericTemplate.hs" #-} + +{-# LINE 45 "GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act) +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + case s of + -1# -> (last_acc, input) + _ -> alex_scan_tkn' user orig_input len input s last_acc + +alex_scan_tkn' user orig_input len input s last_acc = + let + new_acc = check_accs (alex_accept `quickIndex` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/src-3.0/GF/JavaScript/LexJS.x b/src-3.0/GF/JavaScript/LexJS.x new file mode 100644 index 000000000..10ba66d69 --- /dev/null +++ b/src-3.0/GF/JavaScript/LexJS.x @@ -0,0 +1,132 @@ +-- -*- 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-3.0/GF/JavaScript/Makefile b/src-3.0/GF/JavaScript/Makefile new file mode 100644 index 000000000..10f867b06 --- /dev/null +++ b/src-3.0/GF/JavaScript/Makefile @@ -0,0 +1,14 @@ +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-3.0/GF/JavaScript/ParJS.hs b/src-3.0/GF/JavaScript/ParJS.hs new file mode 100644 index 000000000..f57c44a22 --- /dev/null +++ b/src-3.0/GF/JavaScript/ParJS.hs @@ -0,0 +1,1175 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +module GF.JavaScript.ParJS where +import GF.JavaScript.AbsJS +import GF.JavaScript.LexJS +import GF.Data.ErrM +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.16 + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn4 :: (Ident) -> (HappyAbsSyn ) +happyIn4 x = unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> (Ident) +happyOut4 x = unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (Integer) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Integer) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Double) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Double) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (String) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (String) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Program) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (Program) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Element) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Element) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: ([Element]) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> ([Element]) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: ([Ident]) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> ([Ident]) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Stmt) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Stmt) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([Stmt]) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([Stmt]) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (DeclOrExpr) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (DeclOrExpr) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (DeclVar) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (DeclVar) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: ([DeclVar]) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> ([DeclVar]) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (Expr) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (Expr) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Expr) -> (HappyAbsSyn ) +happyIn18 x = unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (Expr) +happyOut18 x = unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: (Expr) -> (HappyAbsSyn ) +happyIn19 x = unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> (Expr) +happyOut19 x = unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: (Expr) -> (HappyAbsSyn ) +happyIn20 x = unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> (Expr) +happyOut20 x = unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: ([Expr]) -> (HappyAbsSyn ) +happyIn21 x = unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> ([Expr]) +happyOut21 x = unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (Expr) -> (HappyAbsSyn ) +happyIn22 x = unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (Expr) +happyOut22 x = unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: (Expr) -> (HappyAbsSyn ) +happyIn23 x = unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> (Expr) +happyOut23 x = unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: (Expr) -> (HappyAbsSyn ) +happyIn24 x = unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> (Expr) +happyOut24 x = unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: (Expr) -> (HappyAbsSyn ) +happyIn25 x = unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> (Expr) +happyOut25 x = unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: (Expr) -> (HappyAbsSyn ) +happyIn26 x = unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> (Expr) +happyOut26 x = unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: (Expr) -> (HappyAbsSyn ) +happyIn27 x = unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> (Expr) +happyOut27 x = unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: (Expr) -> (HappyAbsSyn ) +happyIn28 x = unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> (Expr) +happyOut28 x = unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: (Expr) -> (HappyAbsSyn ) +happyIn29 x = unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> (Expr) +happyOut29 x = unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: (Expr) -> (HappyAbsSyn ) +happyIn30 x = unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> (Expr) +happyOut30 x = unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: (Expr) -> (HappyAbsSyn ) +happyIn31 x = unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> (Expr) +happyOut31 x = unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: (Expr) -> (HappyAbsSyn ) +happyIn32 x = unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> (Expr) +happyOut32 x = unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: (Expr) -> (HappyAbsSyn ) +happyIn33 x = unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> (Expr) +happyOut33 x = unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: (Expr) -> (HappyAbsSyn ) +happyIn34 x = unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> (Expr) +happyOut34 x = unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: (Property) -> (HappyAbsSyn ) +happyIn35 x = unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> (Property) +happyOut35 x = unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: ([Property]) -> (HappyAbsSyn ) +happyIn36 x = unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> ([Property]) +happyOut36 x = unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (PropertyName) -> (HappyAbsSyn ) +happyIn37 x = unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> (PropertyName) +happyOut37 x = unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x00\x00\x9d\x00\x00\x00\x96\x00\x02\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\xab\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x02\xfe\xff\x30\x02\x00\x00\x02\x00\x9a\x00\x00\x00\x19\x02\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x3c\x00\x00\x00\xaa\x00\x93\x00\x92\x00\x7e\x00\x87\x00\x8b\x00\x00\x00\x00\x00\xeb\x01\x8a\x00\x89\x00\x83\x00\x12\x00\x30\x02\x61\x00\x30\x02\x30\x02\x00\x00\x00\x00\x82\x00\x00\x00\x72\x00\x00\x00\x30\x02\x30\x02\x00\x00\x20\x00\x00\x00\x00\x00\x30\x02\x00\x00\x6e\x00\x70\x00\x5d\x00\x30\x02\x00\x00\x5d\x00\x30\x02\x00\x00\x00\x00\x6d\x00\x6b\x00\x59\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\xd4\x01\x00\x00\xbd\x01\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x6a\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x01\x01\x00\x04\x01\x00\x00\x27\x00\x0b\x00\x00\x00\x80\x01\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x07\x00\x61\x01\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x42\x01\x00\x00\x05\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x69\x00\x00\x00\x13\x00\x23\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\xfd\xff\x4a\x00\x00\x00\x4a\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xf7\xff\x00\x00\xfe\xff\x00\x00\xfa\xff\xdd\xff\xdc\xff\xdb\xff\xda\xff\xf6\xff\xf8\xff\x00\x00\xc1\xff\xe4\xff\xe2\xff\xde\xff\xeb\xff\xcc\xff\xcb\xff\xca\xff\xc9\xff\xc8\xff\xc7\xff\xc6\xff\xc5\xff\xc4\xff\xc3\xff\xc2\xff\x00\x00\xee\xff\xd0\xff\xd8\xff\x00\x00\x00\x00\xd7\xff\x00\x00\xd6\xff\xd9\xff\xe8\xff\xfd\xff\xfc\xff\xfb\xff\xea\xff\xe7\xff\xec\xff\x00\x00\xcd\xff\xbf\xff\xf1\xff\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xcf\xff\xbc\xff\xbb\xff\x00\x00\xbe\xff\x00\x00\x00\x00\x00\x00\xd0\xff\x00\x00\x00\x00\x00\x00\xef\xff\xe5\xff\x00\x00\xe1\xff\x00\x00\xd1\xff\xd0\xff\x00\x00\xd3\xff\xbf\xff\xed\xff\xf2\xff\xd0\xff\xd4\xff\xf4\xff\x00\x00\xf5\xff\xd0\xff\xf0\xff\xe8\xff\x00\x00\xe9\xff\xe6\xff\x00\x00\x00\x00\x00\x00\xf5\xff\xce\xff\xbd\xff\xc0\xff\x00\x00\xdf\xff\xe0\xff\xd2\xff\xf3\xff\xee\xff\x00\x00\xe3\xff\xee\xff\x00\x00\xd5\xff\x00\x00\xf9\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x00\x00\x04\x00\x01\x00\x03\x00\x00\x00\x09\x00\x00\x00\x03\x00\x00\x00\x09\x00\x00\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x01\x00\x14\x00\x00\x00\x02\x00\x17\x00\x14\x00\x05\x00\x08\x00\x09\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x0c\x00\x1f\x00\x20\x00\x21\x00\x09\x00\x1f\x00\x20\x00\x21\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x05\x00\x00\x00\x02\x00\x08\x00\x14\x00\x0a\x00\x07\x00\x17\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x0c\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x00\x00\x14\x00\x14\x00\x08\x00\x17\x00\x0a\x00\x07\x00\x07\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x03\x00\x03\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x04\x00\x02\x00\x06\x00\x14\x00\x02\x00\x05\x00\x02\x00\x14\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0a\x00\x04\x00\x0b\x00\x05\x00\x05\x00\x0a\x00\x14\x00\x01\x00\x01\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x01\x00\x06\x00\x05\x00\x14\x00\x19\x00\x07\x00\x14\x00\x07\x00\x06\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x12\x00\xff\xff\x14\x00\x15\x00\x16\x00\x17\x00\x01\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x0c\x00\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\x12\x00\xff\xff\x14\x00\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x37\x00\xbf\xff\x35\x00\x38\x00\x37\x00\x6b\x00\x45\x00\x38\x00\x37\x00\x39\x00\x32\x00\x38\x00\x05\x00\x06\x00\x07\x00\x08\x00\x3f\x00\x03\x00\x2a\x00\x48\x00\x2a\x00\x03\x00\x49\x00\x40\x00\x41\x00\x43\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x00\x58\x00\x3a\x00\x3b\x00\x3c\x00\x69\x00\x3a\x00\x5e\x00\x3c\x00\x33\x00\x3a\x00\x3b\x00\x3c\x00\x05\x00\x06\x00\x07\x00\x08\x00\x50\x00\x09\x00\x2a\x00\x64\x00\x0a\x00\x03\x00\x0b\x00\x64\x00\x2a\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x2b\x00\x2c\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x50\x00\x50\x00\x03\x00\x03\x00\x4c\x00\x2a\x00\x0b\x00\x5a\x00\x51\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x69\x00\x66\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x67\x00\x03\x00\x68\x00\x04\x00\x03\x00\x5c\x00\x5d\x00\x62\x00\x03\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x59\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x63\x00\x4b\x00\x4a\x00\x4c\x00\x4f\x00\x50\x00\x03\x00\x53\x00\x54\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x5d\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x35\x00\x55\x00\x56\x00\x03\x00\xff\xff\x57\x00\x03\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x60\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x46\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x00\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x35\x00\x36\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x57\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x5f\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x44\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x2d\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x00\x00\x3d\x00\x2e\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1d\x00\x00\x00\x1e\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x1e\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x1e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x30\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x00\x00\x25\x00\x26\x00\x00\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x32\x00\x22\x00\x23\x00\x00\x00\x25\x00\x26\x00\x00\x00\x03\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (1, 68) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68) + ] + +happy_n_terms = 26 :: Int +happy_n_nonterms = 34 :: Int + +happyReduce_1 = happySpecReduce_1 0# happyReduction_1 +happyReduction_1 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> + happyIn4 + (Ident happy_var_1 + )} + +happyReduce_2 = happySpecReduce_1 1# happyReduction_2 +happyReduction_2 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> + happyIn5 + ((read happy_var_1) :: Integer + )} + +happyReduce_3 = happySpecReduce_1 2# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> + happyIn6 + ((read happy_var_1) :: Double + )} + +happyReduce_4 = happySpecReduce_1 3# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> + happyIn7 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_1 4# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn8 + (Program (reverse happy_var_1) + )} + +happyReduce_6 = happyReduce 8# 5# happyReduction_6 +happyReduction_6 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut4 happy_x_2 of { happy_var_2 -> + case happyOut11 happy_x_4 of { happy_var_4 -> + case happyOut13 happy_x_7 of { happy_var_7 -> + happyIn9 + (FunDef happy_var_2 happy_var_4 (reverse happy_var_7) + ) `HappyStk` happyRest}}} + +happyReduce_7 = happySpecReduce_1 5# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn9 + (ElStmt happy_var_1 + )} + +happyReduce_8 = happySpecReduce_0 6# happyReduction_8 +happyReduction_8 = happyIn10 + ([] + ) + +happyReduce_9 = happySpecReduce_2 6# happyReduction_9 +happyReduction_9 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn10 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_10 = happySpecReduce_0 7# happyReduction_10 +happyReduction_10 = happyIn11 + ([] + ) + +happyReduce_11 = happySpecReduce_1 7# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn11 + ((:[]) happy_var_1 + )} + +happyReduce_12 = happySpecReduce_3 7# happyReduction_12 +happyReduction_12 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + happyIn11 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_13 = happySpecReduce_3 8# happyReduction_13 +happyReduction_13 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn12 + (SCompound (reverse happy_var_2) + )} + +happyReduce_14 = happySpecReduce_2 8# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = happyIn12 + (SReturnVoid + ) + +happyReduce_15 = happySpecReduce_3 8# happyReduction_15 +happyReduction_15 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn12 + (SReturn happy_var_2 + )} + +happyReduce_16 = happySpecReduce_2 8# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + happyIn12 + (SDeclOrExpr happy_var_1 + )} + +happyReduce_17 = happySpecReduce_0 9# happyReduction_17 +happyReduction_17 = happyIn13 + ([] + ) + +happyReduce_18 = happySpecReduce_2 9# happyReduction_18 +happyReduction_18 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn13 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_19 = happySpecReduce_2 10# happyReduction_19 +happyReduction_19 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn14 + (Decl happy_var_2 + )} + +happyReduce_20 = happySpecReduce_1 10# happyReduction_20 +happyReduction_20 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn14 + (DExpr happy_var_1 + )} + +happyReduce_21 = happySpecReduce_1 11# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn15 + (DVar happy_var_1 + )} + +happyReduce_22 = happySpecReduce_3 11# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_3 of { happy_var_3 -> + happyIn15 + (DInit happy_var_1 happy_var_3 + )}} + +happyReduce_23 = happySpecReduce_0 12# happyReduction_23 +happyReduction_23 = happyIn16 + ([] + ) + +happyReduce_24 = happySpecReduce_1 12# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn16 + ((:[]) happy_var_1 + )} + +happyReduce_25 = happySpecReduce_3 12# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn16 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_26 = happySpecReduce_3 13# happyReduction_26 +happyReduction_26 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_3 of { happy_var_3 -> + happyIn17 + (EAssign happy_var_1 happy_var_3 + )}} + +happyReduce_27 = happySpecReduce_1 13# happyReduction_27 +happyReduction_27 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn17 + (happy_var_1 + )} + +happyReduce_28 = happyReduce 5# 14# happyReduction_28 +happyReduction_28 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut4 happy_x_2 of { happy_var_2 -> + case happyOut21 happy_x_4 of { happy_var_4 -> + happyIn18 + (ENew happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_29 = happySpecReduce_1 14# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOut19 happy_x_1 of { happy_var_1 -> + happyIn18 + (happy_var_1 + )} + +happyReduce_30 = happySpecReduce_3 15# happyReduction_30 +happyReduction_30 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_3 of { happy_var_3 -> + happyIn19 + (EMember happy_var_1 happy_var_3 + )}} + +happyReduce_31 = happyReduce 4# 15# happyReduction_31 +happyReduction_31 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_3 of { happy_var_3 -> + happyIn19 + (EIndex happy_var_1 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_32 = happyReduce 4# 15# happyReduction_32 +happyReduction_32 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut19 happy_x_1 of { happy_var_1 -> + case happyOut21 happy_x_3 of { happy_var_3 -> + happyIn19 + (ECall happy_var_1 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_33 = happySpecReduce_1 15# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn19 + (happy_var_1 + )} + +happyReduce_34 = happySpecReduce_1 16# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn20 + (EVar happy_var_1 + )} + +happyReduce_35 = happySpecReduce_1 16# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn20 + (EInt happy_var_1 + )} + +happyReduce_36 = happySpecReduce_1 16# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn20 + (EDbl happy_var_1 + )} + +happyReduce_37 = happySpecReduce_1 16# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn20 + (EStr happy_var_1 + )} + +happyReduce_38 = happySpecReduce_1 16# happyReduction_38 +happyReduction_38 happy_x_1 + = happyIn20 + (ETrue + ) + +happyReduce_39 = happySpecReduce_1 16# happyReduction_39 +happyReduction_39 happy_x_1 + = happyIn20 + (EFalse + ) + +happyReduce_40 = happySpecReduce_1 16# happyReduction_40 +happyReduction_40 happy_x_1 + = happyIn20 + (ENull + ) + +happyReduce_41 = happySpecReduce_1 16# happyReduction_41 +happyReduction_41 happy_x_1 + = happyIn20 + (EThis + ) + +happyReduce_42 = happyReduce 7# 16# happyReduction_42 +happyReduction_42 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut11 happy_x_3 of { happy_var_3 -> + case happyOut13 happy_x_6 of { happy_var_6 -> + happyIn20 + (EFun happy_var_3 (reverse happy_var_6) + ) `HappyStk` happyRest}} + +happyReduce_43 = happySpecReduce_3 16# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn20 + (EArray happy_var_2 + )} + +happyReduce_44 = happySpecReduce_3 16# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn20 + (EObj happy_var_2 + )} + +happyReduce_45 = happyReduce 5# 16# happyReduction_45 +happyReduction_45 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOut21 happy_x_4 of { happy_var_4 -> + happyIn20 + (eseq1_ happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_46 = happySpecReduce_3 16# happyReduction_46 +happyReduction_46 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn20 + (happy_var_2 + )} + +happyReduce_47 = happySpecReduce_0 17# happyReduction_47 +happyReduction_47 = happyIn21 + ([] + ) + +happyReduce_48 = happySpecReduce_1 17# happyReduction_48 +happyReduction_48 happy_x_1 + = case happyOut22 happy_x_1 of { happy_var_1 -> + happyIn21 + ((:[]) happy_var_1 + )} + +happyReduce_49 = happySpecReduce_3 17# happyReduction_49 +happyReduction_49 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut22 happy_x_1 of { happy_var_1 -> + case happyOut21 happy_x_3 of { happy_var_3 -> + happyIn21 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_50 = happySpecReduce_1 18# happyReduction_50 +happyReduction_50 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn22 + (happy_var_1 + )} + +happyReduce_51 = happySpecReduce_1 19# happyReduction_51 +happyReduction_51 happy_x_1 + = case happyOut24 happy_x_1 of { happy_var_1 -> + happyIn23 + (happy_var_1 + )} + +happyReduce_52 = happySpecReduce_1 20# happyReduction_52 +happyReduction_52 happy_x_1 + = case happyOut25 happy_x_1 of { happy_var_1 -> + happyIn24 + (happy_var_1 + )} + +happyReduce_53 = happySpecReduce_1 21# happyReduction_53 +happyReduction_53 happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + happyIn25 + (happy_var_1 + )} + +happyReduce_54 = happySpecReduce_1 22# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn26 + (happy_var_1 + )} + +happyReduce_55 = happySpecReduce_1 23# happyReduction_55 +happyReduction_55 happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + happyIn27 + (happy_var_1 + )} + +happyReduce_56 = happySpecReduce_1 24# happyReduction_56 +happyReduction_56 happy_x_1 + = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn28 + (happy_var_1 + )} + +happyReduce_57 = happySpecReduce_1 25# happyReduction_57 +happyReduction_57 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn29 + (happy_var_1 + )} + +happyReduce_58 = happySpecReduce_1 26# happyReduction_58 +happyReduction_58 happy_x_1 + = case happyOut31 happy_x_1 of { happy_var_1 -> + happyIn30 + (happy_var_1 + )} + +happyReduce_59 = happySpecReduce_1 27# happyReduction_59 +happyReduction_59 happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn31 + (happy_var_1 + )} + +happyReduce_60 = happySpecReduce_1 28# happyReduction_60 +happyReduction_60 happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + happyIn32 + (happy_var_1 + )} + +happyReduce_61 = happySpecReduce_1 29# happyReduction_61 +happyReduction_61 happy_x_1 + = case happyOut34 happy_x_1 of { happy_var_1 -> + happyIn33 + (happy_var_1 + )} + +happyReduce_62 = happySpecReduce_1 30# happyReduction_62 +happyReduction_62 happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + happyIn34 + (happy_var_1 + )} + +happyReduce_63 = happySpecReduce_3 31# happyReduction_63 +happyReduction_63 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_3 of { happy_var_3 -> + happyIn35 + (Prop happy_var_1 happy_var_3 + )}} + +happyReduce_64 = happySpecReduce_0 32# happyReduction_64 +happyReduction_64 = happyIn36 + ([] + ) + +happyReduce_65 = happySpecReduce_1 32# happyReduction_65 +happyReduction_65 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn36 + ((:[]) happy_var_1 + )} + +happyReduce_66 = happySpecReduce_3 32# happyReduction_66 +happyReduction_66 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn36 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_67 = happySpecReduce_1 33# happyReduction_67 +happyReduction_67 happy_x_1 + = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn37 + (IdentPropName happy_var_1 + )} + +happyReduce_68 = happySpecReduce_1 33# happyReduction_68 +happyReduction_68 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn37 + (StringPropName happy_var_1 + )} + +happyNewToken action sts stk [] = + happyDoAction 25# (error "reading EOF!") action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + PT _ (TS "(") -> cont 1#; + PT _ (TS ")") -> cont 2#; + PT _ (TS "{") -> cont 3#; + PT _ (TS "}") -> cont 4#; + PT _ (TS ",") -> cont 5#; + PT _ (TS ";") -> cont 6#; + PT _ (TS "=") -> cont 7#; + PT _ (TS ".") -> cont 8#; + PT _ (TS "[") -> cont 9#; + PT _ (TS "]") -> cont 10#; + PT _ (TS ":") -> cont 11#; + PT _ (TS "false") -> cont 12#; + PT _ (TS "function") -> cont 13#; + PT _ (TS "new") -> cont 14#; + PT _ (TS "null") -> cont 15#; + PT _ (TS "return") -> cont 16#; + PT _ (TS "this") -> cont 17#; + PT _ (TS "true") -> cont 18#; + PT _ (TS "var") -> cont 19#; + PT _ (TV happy_dollar_dollar) -> cont 20#; + PT _ (TI happy_dollar_dollar) -> cont 21#; + PT _ (TD happy_dollar_dollar) -> cont 22#; + PT _ (TL happy_dollar_dollar) -> cont 23#; + _ -> cont 24#; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +happyThen :: () => Err a -> (a -> Err b) -> Err b +happyThen = (thenM) +happyReturn :: () => a -> Err a +happyReturn = (returnM) +happyThen1 m k tks = (thenM) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Err a +happyReturn1 = \a tks -> (returnM) a +happyError' :: () => [Token] -> Err a +happyError' = happyError + +pProgram tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut8 x)) + +happySeq = happyDontSeq + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + _ -> " before " ++ unwords (map prToken (take 4 ts)) + +myLexer = tokens +eseq1_ x_ xs_ = ESeq (x_ : xs_) +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id$ + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + +{-# LINE 59 "GenericTemplate.hs" #-} + +{-# LINE 68 "GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 127 "GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src-3.0/GF/JavaScript/ParJS.y b/src-3.0/GF/JavaScript/ParJS.y new file mode 100644 index 000000000..bf0614757 --- /dev/null +++ b/src-3.0/GF/JavaScript/ParJS.y @@ -0,0 +1,225 @@ +-- 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-3.0/GF/JavaScript/PrintJS.hs b/src-3.0/GF/JavaScript/PrintJS.hs new file mode 100644 index 000000000..66e78346e --- /dev/null +++ b/src-3.0/GF/JavaScript/PrintJS.hs @@ -0,0 +1,169 @@ +{-# 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-3.0/GF/JavaScript/SkelJS.hs b/src-3.0/GF/JavaScript/SkelJS.hs new file mode 100644 index 000000000..f8cd588a7 --- /dev/null +++ b/src-3.0/GF/JavaScript/SkelJS.hs @@ -0,0 +1,80 @@ +module GF.JavaScript.SkelJS where + +-- Haskell module generated by the BNF converter + +import GF.JavaScript.AbsJS +import GF.Data.ErrM +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Result +transIdent x = case x of + Ident str -> failure x + + +transProgram :: Program -> Result +transProgram x = case x of + Program elements -> failure x + + +transElement :: Element -> Result +transElement x = case x of + FunDef id ids stmts -> failure x + ElStmt stmt -> failure x + + +transStmt :: Stmt -> Result +transStmt x = case x of + SCompound stmts -> failure x + SReturnVoid -> failure x + SReturn expr -> failure x + SDeclOrExpr declorexpr -> failure x + + +transDeclOrExpr :: DeclOrExpr -> Result +transDeclOrExpr x = case x of + Decl declvars -> failure x + DExpr expr -> failure x + + +transDeclVar :: DeclVar -> Result +transDeclVar x = case x of + DVar id -> failure x + DInit id expr -> failure x + + +transExpr :: Expr -> Result +transExpr x = case x of + EAssign expr0 expr -> failure x + ENew id exprs -> failure x + EMember expr id -> failure x + EIndex expr0 expr -> failure x + ECall expr exprs -> failure x + EVar id -> failure x + EInt n -> failure x + EDbl d -> failure x + EStr str -> failure x + ETrue -> failure x + EFalse -> failure x + ENull -> failure x + EThis -> failure x + EFun ids stmts -> failure x + EArray exprs -> failure x + EObj propertys -> failure x + ESeq exprs -> failure x + + +transProperty :: Property -> Result +transProperty x = case x of + Prop propertyname expr -> failure x + + +transPropertyName :: PropertyName -> Result +transPropertyName x = case x of + IdentPropName id -> failure x + StringPropName str -> failure x + + + diff --git a/src-3.0/GF/JavaScript/TestJS.hs b/src-3.0/GF/JavaScript/TestJS.hs new file mode 100644 index 000000000..3ddb52074 --- /dev/null +++ b/src-3.0/GF/JavaScript/TestJS.hs @@ -0,0 +1,58 @@ +-- automatically generated by BNF Converter +module Main where + + +import IO ( stdin, hGetContents ) +import System ( getArgs, getProgName ) + +import GF.JavaScript.LexJS +import GF.JavaScript.ParJS +import GF.JavaScript.SkelJS +import GF.JavaScript.PrintJS +import GF.JavaScript.AbsJS + + + + +import GF.Data.ErrM + +type ParseFun a = [Token] -> Err a + +myLLexer = myLexer + +type Verbosity = Int + +putStrV :: Verbosity -> String -> IO () +putStrV v s = if v > 1 then putStrLn s else return () + +runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () +runFile v p f = putStrLn f >> readFile f >>= run v p + +run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () +run v p s = let ts = myLLexer s in case p ts of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrV v "Tokens:" + putStrV v $ show ts + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + showTree v tree + + + +showTree :: (Show a, Print a) => Int -> a -> IO () +showTree v tree + = do + putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree + +main :: IO () +main = do args <- getArgs + case args of + [] -> hGetContents stdin >>= run 2 pProgram + "-s":fs -> mapM_ (runFile 0 pProgram) fs + fs -> mapM_ (runFile 2 pProgram) fs + + + + + diff --git a/src-3.0/GF/OldParsing/CFGrammar.hs b/src-3.0/GF/OldParsing/CFGrammar.hs new file mode 100644 index 000000000..5a71fe0ab --- /dev/null +++ b/src-3.0/GF/OldParsing/CFGrammar.hs @@ -0,0 +1,153 @@ +---------------------------------------------------------------------- +-- | +-- Module : CFGrammar +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:41 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Definitions of context-free grammars, +-- parser information and chart conversion +---------------------------------------------------------------------- + +module GF.OldParsing.CFGrammar + (-- * Type definitions + Grammar, + Rule(..), + CFParser, + -- * Parser information + pInfo, + PInfo(..), + -- * Building parse charts + edges2chart, + -- * Grammar checking + checkGrammar + ) where + +import GF.System.Tracing + +-- haskell modules: +import Data.Array +-- gf modules: +import GF.Data.SortedList +import GF.Data.Assoc +import qualified GF.CF.CF as CF +-- parser modules: +import GF.OldParsing.Utilities +import GF.Printing.PrintParser + + +------------------------------------------------------------ +-- type definitions + +type Grammar n c t = [Rule n c t] +data Rule n c t = Rule c [Symbol c t] n + deriving (Eq, Ord, Show) + + +type CFParser n c t = PInfo n c t -> [c] -> Input t -> [Edge (Rule n c t)] +-- - - - - - - - - - - - - - - - - - ^^^ possible starting categories + + +------------------------------------------------------------ +-- parser information + +pInfo :: (Ord n, Ord c, Ord t) => Grammar n c t -> PInfo n c t + +data PInfo n c t + = PInfo { grammarTokens :: SList t, + nameRules :: Assoc n (SList (Rule n c t)), + topdownRules :: Assoc c (SList (Rule n c t)), + bottomupRules :: Assoc (Symbol c t) (SList (Rule n c t)), + emptyLeftcornerRules :: Assoc c (SList (Rule n c t)), + emptyCategories :: Set c, + cyclicCategories :: SList c, + -- ^^ONLY FOR DIRECT CYCLIC RULES!!! + leftcornerTokens :: Assoc c (SList t) + -- ^^DOES NOT WORK WITH EMPTY RULES!!! + } + +-- this is not permanent... +pInfo grammar = pInfo' (filter (not.isCyclic) grammar) + +pInfo' grammar = tracePrt "#parserInfo" prt $ + PInfo grToks nmRules tdRules buRules elcRules emptyCats cyclicCats leftToks + where grToks = union [ nubsort [ tok | Tok tok <- rhs ] | Rule _ rhs _ <- grammar ] + nmRules = accumAssoc id [ (name, rule) | rule@(Rule _ _ name) <- grammar ] + tdRules = accumAssoc id [ (cat, rule) | rule@(Rule cat _ _) <- grammar ] + buRules = accumAssoc id [ (next, rule) | rule@(Rule _ (next:_) _) <- grammar ] + elcRules = accumAssoc id $ limit lc emptyRules + leftToks = accumAssoc id $ limit lc $ + nubsort [ (cat, token) | Rule cat (Tok token:_) _ <- grammar ] + lc (left, res) = nubsort [ (cat, res) | Rule cat _ _ <- buRules ? Cat left ] + emptyRules = nubsort [ (cat, rule) | rule@(Rule cat [] _) <- grammar ] + emptyCats = listSet $ limitEmpties $ map fst emptyRules + limitEmpties es = if es==es' then es else limitEmpties es' + where es' = nubsort [ cat | Rule cat rhs _ <- grammar, + all (symbol (`elem` es) (const False)) rhs ] + cyclicCats = nubsort [ cat | Rule cat [Cat cat'] _ <- grammar, cat == cat' ] + +isCyclic (Rule cat [Cat cat'] _) = cat==cat' +isCyclic _ = False + +------------------------------------------------------------ +-- building parse charts + +edges2chart :: (Ord n, Ord c, Ord t) => Input t -> + [Edge (Rule n c t)] -> ParseChart n (Edge c) + +---------- + +edges2chart input edges + = accumAssoc id [ (Edge i k cat, (name, children i k rhs)) | + Edge i k (Rule cat rhs name) <- edges ] + where children i k [] = [ [] | i == k ] + children i k (Tok tok:rhs) = [ rest | i <= k, + j <- (inputFrom input ! i) ? tok, + rest <- children j k rhs ] + children i k (Cat cat:rhs) = [ Edge i j cat : rest | i <= k, + j <- echart ? (i, cat), + rest <- children j k rhs ] + echart = accumAssoc id [ ((i, cat), j) | Edge i j (Rule cat _ _) <- edges ] + + +------------------------------------------------------------ +-- grammar checking + +checkGrammar :: (Ord n, Ord c, Ord t, Print n, Print c, Print t) => + Grammar n c t -> [String] + +---------- + +checkGrammar rules = [ "rhs category does not exist: " ++ prt cat ++ "\n" ++ + " in rule: " ++ prt rule | + rule@(Rule _ rhs _) <- rules, + Cat cat <- rhs, cat `notElem` cats ] + where cats = nubsort [ cat | Rule cat _ _ <- rules ] + + +------------------------------------------------------------ +-- pretty-printing + +instance (Print n, Print c, Print t) => Print (Rule n c t) where + prt (Rule cat rhs name) = prt name ++ ". " ++ prt cat ++ " -> " ++ prt rhs ++ + (if null rhs then ".\n" else "\n") + prtList = concatMap prt + + +instance (Ord n, Ord c, Ord t) => Print (PInfo n c t) where + prt pI = "[ tokens=" ++ show (length (grammarTokens pI)) ++ + "; names=" ++ sla nameRules ++ + "; tdCats=" ++ sla topdownRules ++ + "; buCats=" ++ sla bottomupRules ++ + "; elcCats=" ++ sla emptyLeftcornerRules ++ + "; eCats=" ++ sla emptyCategories ++ + "; cCats=" ++ show (length (cyclicCategories pI)) ++ + -- "; lctokCats=" ++ sla leftcornerTokens ++ + " ]" + where sla f = show $ length $ aElems $ f pI + + diff --git a/src-3.0/GF/OldParsing/ConvertFiniteGFC.hs b/src-3.0/GF/OldParsing/ConvertFiniteGFC.hs new file mode 100644 index 000000000..25ed3fdb3 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertFiniteGFC.hs @@ -0,0 +1,283 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:42 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Calculating the finiteness of each type in a grammar +----------------------------------------------------------------------------- + +module GF.OldParsing.ConvertFiniteGFC where + +import GF.Data.Operations +import GF.Canon.GFC +import GF.Canon.MkGFC +import GF.Canon.AbsGFC +import GF.Infra.Ident (Ident(..)) +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Data.BacktrackM + +type Cat = Ident +type Name = Ident + +type CnvMonad a = BacktrackM () a + +convertGrammar :: CanonGrammar -> CanonGrammar +convertGrammar = canon2grammar . convertCanon . grammar2canon + +convertCanon :: Canon -> Canon +convertCanon (Gr modules) = Gr (map (convertModule split) modules) + where split = calcSplitable modules + +convertModule :: Splitable -> Module -> Module +convertModule split (Mod mtyp ext op fl defs) + = Mod mtyp ext op fl newDefs + where newDefs = solutions defMonad () + defMonad = member defs >>= convertDef split + +---------------------------------------------------------------------- +-- the main conversion function +convertDef :: Splitable -> Def -> CnvMonad Def + +-- converting abstract "cat" definitions +convertDef split (AbsDCat cat decls cidents) + = case splitableCat split cat of + Just newCats -> do newCat <- member newCats + return $ AbsDCat newCat decls cidents + Nothing -> do (newCat, newDecls) <- expandDecls cat decls + return $ AbsDCat newCat newDecls cidents + where expandDecls cat [] = return (cat, []) + expandDecls cat (decl@(Decl var typ) : decls) + = do (newCat, newDecls) <- expandDecls cat decls + let argCat = resultCat typ + case splitableCat split argCat of + Nothing -> return (newCat, decl : newDecls) + Just newArgs -> do newArg <- member newArgs + return (mergeArg newCat newArg, newDecls) + +-- converting abstract "fun" definitions +convertDef split (AbsDFun fun typ@(EAtom (AC (CIQ mod cat))) def) + = case splitableFun split fun of + Just newCat -> return (AbsDFun fun (EAtom (AC (CIQ mod newCat))) def) + Nothing -> do newTyp <- expandType split [] typ + return (AbsDFun fun newTyp def) +convertDef split (AbsDFun fun typ def) + = do newTyp <- expandType split [] typ + return (AbsDFun fun newTyp def) + +-- converting concrete "lincat" definitions +convertDef split (CncDCat cat ctype x y) + = case splitableCat split cat of + Just newCats -> do newCat <- member newCats + return $ CncDCat newCat ctype x y + Nothing -> return $ CncDCat cat ctype x y + +-- converting concrete "lin" definitions +convertDef split (CncDFun fun (CIQ mod cat) args linterm x) + = case splitableFun split fun of + Just newCat -> return $ CncDFun fun (CIQ mod newCat) args linterm x + Nothing -> return $ CncDFun fun (CIQ mod cat) args linterm x + +convertDef _ def = return def + +---------------------------------------------------------------------- +-- expanding type expressions + +expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp +expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b) + = case splitableCat split cat of + Nothing -> do b' <- expandType split env b + return (EProd x a b') + Just newCats -> do newCat <- member newCats + b' <- expandType split ((x,newCat):env) b + return (EProd x (EAtom (AC (CIQ mod newCat))) b') +expandType split env (EProd x a b) + = do a' <- expandType split env a + b' <- expandType split env b + return (EProd x a' b') +expandType split env app + = expandApp split env [] app + +expandApp :: Splitable -> [(Ident, Cat)] -> [Cat] -> Exp -> CnvMonad Exp +expandApp split env addons (EAtom (AC (CIQ mod cat))) + = return (EAtom (AC (CIQ mod (foldl mergeArg cat addons)))) +expandApp split env addons (EApp exp arg@(EAtom (AC (CIQ mod fun)))) + = case splitableFun split fun of + Just newCat -> expandApp split env (newCat:addons) exp + Nothing -> do exp' <- expandApp split env addons exp + return (EApp exp' arg) +expandApp split env addons (EApp exp arg@(EAtom (AV x))) + = case lookup x env of + Just newCat -> expandApp split env (newCat:addons) exp + Nothing -> do exp' <- expandApp split env addons exp + return (EApp exp' arg) + +---------------------------------------------------------------------- +-- splitable categories (finite, no dependencies) +-- they should also be used as some dependency + +type Splitable = (Assoc Cat [Cat], Assoc Name Cat) + +splitableCat :: Splitable -> Cat -> Maybe [Cat] +splitableCat = lookupAssoc . fst + +splitableFun :: Splitable -> Name -> Maybe Cat +splitableFun = lookupAssoc . snd + +calcSplitable :: [Module] -> Splitable +calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns) + where splitableCats = tracePrt "splitableCats" (prtSep " ") $ + groupPairs $ nubsort + [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ] + + splitableFuns = tracePrt "splitableFuns" (prtSep " ") $ + nubsort + [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ] + + constantCats = tracePrt "constantCats" (prtSep " ") $ + [ (cat, fun) | + AbsDFun fun (EAtom (AC (CIQ _ cat))) _ <- absDefs, + dependentConstants ?= cat ] + + dependentConstants = listSet $ + tracePrt "dep consts" prt $ + dependentCats <\\> funCats + + funCats = tracePrt "fun cats" prt $ + nubsort [ resultCat typ | + AbsDFun _ typ@(EProd _ _ _) _ <- absDefs ] + + dependentCats = tracePrt "dep cats" prt $ + nubsort [ cat | AbsDCat _ decls _ <- absDefs, + Decl _ (EAtom (AC (CIQ _ cat))) <- decls ] + + absDefs = concat [ defs | Mod (MTAbs _) _ _ _ defs <- modules ] + + +---------------------------------------------------------------------- +-- utilities + +-- the main result category of a type expression +resultCat :: Exp -> Cat +resultCat (EProd _ _ b) = resultCat b +resultCat (EApp a _) = resultCat a +resultCat (EAtom (AC (CIQ _ cat))) = cat + +-- mergeing categories +mergeCats :: String -> String -> String -> Cat -> Cat -> Cat +mergeCats before middle after (IC cat) (IC arg) + = IC (before ++ cat ++ middle ++ arg ++ after) + +mergeFun, mergeArg :: Cat -> Cat -> Cat +mergeFun = mergeCats "{" ":" "}" +mergeArg = mergeCats "" "" "" + +---------------------------------------------------------------------- +-- obsolete? + +{- +type FiniteCats = Assoc Cat Integer + +calculateFiniteness :: Canon -> FiniteCats +calculateFiniteness canon@(Gr modules) + = trace2 "#typeInfo" (prt tInfo) $ + finiteCats + + where finiteCats = listAssoc [ (cat, fin) | (cat, Just fin) <- finiteInfo ] + finiteInfo = map finInfo groups + + finInfo :: (Cat, [[Cat]]) -> (Cat, Maybe Integer) + finInfo (cat, ctxts) + | cyclicCats ?= cat = (cat, Nothing) + | otherwise = (cat, fmap (sum . map product) $ + sequence (map (sequence . map lookFinCat) ctxts)) + + lookFinCat :: Cat -> Maybe Integer + lookFinCat cat = maybe (error "lookFinCat: Nothing") id $ + lookup cat finiteInfo + + cyclicCats :: Set Cat + cyclicCats = listSet $ + tracePrt "cyclic cats" prt $ + union $ map nubsort $ cyclesIn dependencies + + dependencies :: [(Cat, [Cat])] + dependencies = tracePrt "dependencies" (prtAfter "\n") $ + mapSnd (union . nubsort) groups + + groups :: [(Cat, [[Cat]])] + groups = tracePrt "groups" (prtAfter "\n") $ + mapSnd (map snd) $ groupPairs (nubsort allFuns) + + allFuns = tracePrt "all funs" (prtAfter "\n") $ + [ (cat, (fun, ctxt)) | + Mod (MTAbs _) _ _ _ defs <- modules, + AbsDFun fun typ _ <- defs, + let (cat, ctxt) = err error id $ typeForm typ ] + + tInfo = calculateTypeInfo 30 finiteCats (splitDefs canon) + +-- | stolen from 'Macros.qTypeForm', converted to GFC, and severely simplified +typeForm :: Monad m => Exp -> m (Cat, [Cat]) +typeForm t = case t of + EProd x a b -> do + (cat, ctxt) <- typeForm b + a' <- stripType a + return (cat, a':ctxt) + EApp c a -> do + (cat, _) <- typeForm c + return (cat, []) + EAtom (AC (CIQ _ con)) -> + return (con, []) + _ -> + fail $ "no normal form of type: " ++ prt t + +stripType :: Monad m => Exp -> m Cat +stripType (EApp c a) = stripType c +stripType (EAtom (AC (CIQ _ con))) = return con +stripType t = fail $ "can't strip type: " ++ prt t + +mapSnd f xs = [ (a, f b) | (a, b) <- xs ] +-} + +---------------------------------------------------------------------- +-- obsolete? + +{- +type SplitDefs = ([Def], [Def], [Def], [Def]) +----- AbsDCat AbsDFun CncDCat CncDFun + +splitDefs :: Canon -> SplitDefs +splitDefs (Gr modules) = foldr splitDef ([], [], [], []) $ + concat [ defs | Mod _ _ _ _ defs <- modules ] + +splitDef :: Def -> SplitDefs -> SplitDefs +splitDef ac@(AbsDCat _ _ _) (acs, afs, ccs, cfs) = (ac:acs, afs, ccs, cfs) +splitDef af@(AbsDFun _ _ _) (acs, afs, ccs, cfs) = (acs, af:afs, ccs, cfs) +splitDef cc@(CncDCat _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, cc:ccs, cfs) +splitDef cf@(CncDFun _ _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, ccs, cf:cfs) +splitDef _ sd = sd + +--calculateTypeInfo :: Integer -> FiniteCats -> SplitDefs -> ? +calculateTypeInfo maxFin allFinCats (acs, afs, ccs, cfs) + = (depCatsToExpand, catsToSplit) + where absDefsToExpand = tracePrt "absDefsToExpand" prt $ + [ ((cat, fin), cats) | + AbsDCat cat args _ <- acs, + not (null args), + cats <- mapM catOfDecl args, + fin <- lookupAssoc allFinCats cat, + fin <= maxFin + ] + (depCatsToExpand, argsCats') = unzip absDefsToExpand + catsToSplit = union (map nubsort argsCats') + catOfDecl (Decl _ exp) = err fail return $ stripType exp +-} diff --git a/src-3.0/GF/OldParsing/ConvertFiniteSimple.hs b/src-3.0/GF/OldParsing/ConvertFiniteSimple.hs new file mode 100644 index 000000000..a05092550 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertFiniteSimple.hs @@ -0,0 +1,121 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:43 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Calculating the finiteness of each type in a grammar +----------------------------------------------------------------------------- + +module GF.OldParsing.ConvertFiniteSimple + (convertGrammar) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm + +import GF.Data.Operations +import GF.Infra.Ident (Ident(..)) +import GF.OldParsing.SimpleGFC +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Data.BacktrackM + +type CnvMonad a = BacktrackM () a + +convertGrammar :: Grammar -> Grammar +convertGrammar rules = solutions cnvMonad () + where split = calcSplitable rules + cnvMonad = member rules >>= convertRule split + +convertRule :: Splitable -> Rule -> CnvMonad Rule +convertRule split (Rule name typing term) + = do newTyping <- convertTyping split name typing + return $ Rule name newTyping term + +convertTyping :: Splitable -> Name -> Typing -> CnvMonad Typing +convertTyping split name (typ, decls) + = case splitableFun split name of + Just newCat -> return (newCat :@ [], decls) + Nothing -> expandTyping split [] typ decls [] + + +expandTyping :: Splitable -> [(Var, Cat)] -> Type -> [Decl] -> [Decl] -> CnvMonad Typing +expandTyping split env (cat :@ atoms) [] decls + = return (substAtoms split env cat atoms [], reverse decls) +expandTyping split env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone + = do env' <- calcNewEnv + expandTyping split env' typ declsToDo (decl : declsDone) + where decl = x ::: substAtoms split env xcat xatoms [] + calcNewEnv = case splitableCat split xcat of + Just newCats -> do newCat <- member newCats + return ((x,newCat) : env) + Nothing -> return env + +substAtoms :: Splitable -> [(Var, Cat)] -> Cat -> [Atom] -> [Atom] -> Type +substAtoms split env cat [] atoms = cat :@ reverse atoms +substAtoms split env cat (atom:atomsToDo) atomsDone + = case atomLookup split env atom of + Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone + Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone) + +atomLookup split env (AVar x) = lookup x env +atomLookup split env (ACon con) = splitableFun split (constr2name con) + + +---------------------------------------------------------------------- +-- splitable categories (finite, no dependencies) +-- they should also be used as some dependency + +type Splitable = (Assoc Cat [Cat], Assoc Name Cat) + +splitableCat :: Splitable -> Cat -> Maybe [Cat] +splitableCat = lookupAssoc . fst + +splitableFun :: Splitable -> Name -> Maybe Cat +splitableFun = lookupAssoc . snd + +calcSplitable :: [Rule] -> Splitable +calcSplitable rules = (listAssoc splitableCats, listAssoc splitableFuns) + where splitableCats = tracePrt "splitableCats" (prtSep " ") $ + groupPairs $ nubsort + [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ] + + splitableFuns = tracePrt "splitableFuns" (prtSep " ") $ + nubsort + [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ] + + constantCats = tracePrt "constantCats" (prtSep " ") $ + [ (cat, fun) | + Rule fun (cat :@ [], []) _ <- rules, + dependentConstants ?= cat ] + + dependentConstants = listSet $ + tracePrt "dep consts" prt $ + dependentCats <\\> funCats + + funCats = tracePrt "fun cats" prt $ + nubsort [ cat | Rule _ (cat :@ _, decls) _ <- rules, + not (null decls) ] + + dependentCats = tracePrt "dep cats" prt $ + nubsort [ cat | Rule _ (cat :@ [], []) _ <- rules ] + + +---------------------------------------------------------------------- +-- utilities + +-- mergeing categories +mergeCats :: String -> String -> String -> Cat -> Cat -> Cat +mergeCats before middle after (IC cat) (IC arg) + = IC (before ++ cat ++ middle ++ arg ++ after) + +mergeFun, mergeArg :: Cat -> Cat -> Cat +mergeFun = mergeCats "{" ":" "}" +mergeArg = mergeCats "" "" "" + + diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs new file mode 100644 index 000000000..c32812eb2 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG.hs @@ -0,0 +1,34 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGFCtoMCFG +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:44 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- All different conversions from GFC to MCFG +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertGFCtoMCFG + (convertGrammar) where + +import GF.Canon.GFC (CanonGrammar) +import GF.OldParsing.GrammarTypes +import GF.Infra.Ident (Ident(..)) +import GF.Infra.Option +import GF.System.Tracing + +import qualified GF.OldParsing.ConvertGFCtoMCFG.Old as Old +import qualified GF.OldParsing.ConvertGFCtoMCFG.Nondet as Nondet +import qualified GF.OldParsing.ConvertGFCtoMCFG.Strict as Strict +import qualified GF.OldParsing.ConvertGFCtoMCFG.Coercions as Coerce + +convertGrammar :: String -> (CanonGrammar, Ident) -> MCFGrammar +convertGrammar "nondet" = Coerce.addCoercions . Nondet.convertGrammar +convertGrammar "strict" = Strict.convertGrammar +convertGrammar "old" = Old.convertGrammar + diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs new file mode 100644 index 000000000..3ed6a3f48 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs @@ -0,0 +1,71 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGFCtoMCFG.Coercions +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:54 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Adding coercion functions to a MCFG if necessary. +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertGFCtoMCFG.Coercions (addCoercions) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +-- import PrintGFC +-- import qualified PrGrammar as PG + +import qualified GF.Infra.Ident as Ident +import GF.OldParsing.Utilities +import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) +import GF.Data.SortedList +import Data.List (groupBy) -- , transpose) + +---------------------------------------------------------------------- + +addCoercions :: MCFGrammar -> MCFGrammar +addCoercions rules = coercions ++ rules + where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | + Rule head args lins _ <- rules, + let lbls = [ lbl | Lin lbl _ <- lins ] ] + allHeadSet = nubsort allHeads + allArgSet = union allArgs <\\> map fst allHeadSet + coercions = tracePrt "#coercions total" (prt . length) $ + concat $ + tracePrt "#coercions per cat" (prtList . map length) $ + combineCoercions + (groupBy sameCatFst allHeadSet) + (groupBy sameCat allArgSet) + sameCatFst a b = sameCat (fst a) (fst b) + + +combineCoercions [] _ = [] +combineCoercions _ [] = [] +combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) + = case compare (mainCat $ fst $ head heads) (mainCat $ head args) of + LT -> combineCoercions allHeads allArgs' + GT -> combineCoercions allHeads' allArgs + EQ -> makeCoercion heads args : combineCoercions allHeads allArgs + + +makeCoercion heads args = [ Rule arg [head] lins coercionName | + (head@(MCFCat _ headCns), lbls) <- heads, + let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], + arg@(MCFCat _ argCns) <- args, + argCns `subset` headCns ] + + +coercionName = Ident.IW + +mainCat (MCFCat c _) = c + +sameCat mc1 mc2 = mainCat mc1 == mainCat mc2 + + diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs new file mode 100644 index 000000000..7727aa15f --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Nondet.hs @@ -0,0 +1,281 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGFCtoMCFG.Nondet +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:18 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Converting GFC grammars to MCFG grammars, nondeterministically. +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +-- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertGFCtoMCFG.Nondet (convertGrammar) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +-- import PrintGFC +-- import qualified PrGrammar as PG + +import Control.Monad +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.Look +import GF.Data.Operations +import qualified GF.Infra.Modules as M +import GF.Canon.CMacros (defLinType) +import GF.Canon.MkGFC (grammar2canon) +import GF.OldParsing.Utilities +import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..)) +import GF.Data.SortedList +-- import Maybe (listToMaybe) +import Data.List (groupBy) -- , transpose) + +import GF.Data.BacktrackM + +---------------------------------------------------------------------- + +type Env = (CanonGrammar, Ident) + +convertGrammar :: Env -- ^ the canonical grammar, together with the selected language + -> MCFGrammar -- ^ the resulting MCF grammar +convertGrammar gram = trace2 "language" (prt (snd gram)) $ + trace2 "modules" (prtSep " " modnames) $ + tracePrt "#mcf-rules total" (prt . length) $ + solutions conversion undefined + where Gr modules = grammar2canon (fst gram) + modnames = uncurry M.allExtends gram + conversion = member modules >>= convertModule + convertModule (Mod (MTCnc modname _) _ _ _ defs) + | modname `elem` modnames = member defs >>= convertDef gram + convertModule _ = failure + +convertDef :: Env -> Def -> CnvMonad MCFRule +convertDef env (CncDFun fun (CIQ _ cat) args term _) + | trace2 "converting function" (prt fun) True + = do let iCat : iArgs = map initialMCat (cat : map catOfArg args) + writeState (iCat, iArgs, []) + convertTerm env cat term + (newCat, newArgs, linRec) <- readState + let newTerm = map (instLin newArgs) linRec + return (Rule newCat newArgs newTerm fun) +convertDef _ _ = failure + +instLin newArgs (Lin lbl lin) = Lin lbl (map instSym lin) + where instSym = mapSymbol instCat id + instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg) + +convertTerm :: Env -> Cat -> Term -> CnvMonad () +convertTerm env cat term = do rterm <- simplTerm env term + let ctype = lookupCType env cat + reduceT env ctype rterm emptyPath + +------------------------------------------------------------ + +type CnvMonad a = BacktrackM CMRule a + +type CMRule = (MCFCat, [MCFCat], LinRec) +type LinRec = [Lin Cat Path Tokn] + +initialMCat :: Cat -> MCFCat +initialMCat cat = MCFCat cat [] + +---------------------------------------------------------------------- + +simplTerm :: Env -> Term -> CnvMonad STerm +simplTerm env = simplifyTerm + where + simplifyTerm :: Term -> CnvMonad STerm + simplifyTerm (Arg (A cat nr)) = return (SArg (fromInteger nr) cat emptyPath) + simplifyTerm (Par con terms) = liftM (SCon con) $ mapM simplifyTerm terms + simplifyTerm (R record) = liftM SRec $ mapM simplifyAssign record + simplifyTerm (P term lbl) = liftM (+. lbl) $ simplifyTerm term + simplifyTerm (T ct table) = liftM STbl $ sequence $ concatMap simplifyCase table + simplifyTerm (V ct terms) + = liftM STbl $ sequence [ liftM ((,) pat) (simplifyTerm term) | + (pat, term) <- zip (groundTerms env ct) terms ] + simplifyTerm (S term sel) + = do sterm <- simplifyTerm term + ssel <- simplifyTerm sel + case sterm of + STbl table -> do (pat, val) <- member table + pat =?= ssel + return val + _ -> do sel' <- expandTerm env ssel + return (sterm +! sel') + simplifyTerm (FV terms) = liftM SVariants $ mapM simplifyTerm terms + simplifyTerm (term1 `C` term2) = liftM2 (SConcat) (simplifyTerm term1) (simplifyTerm term2) + simplifyTerm (K tokn) = return $ SToken tokn + simplifyTerm (E) = return $ SEmpty + simplifyTerm x = error $ "simplifyTerm: " ++ show x +-- error constructors: +-- (I CIdent) - from resource +-- (LI Ident) - pattern variable +-- (EInt Integer) - integer + + simplifyAssign :: Assign -> CnvMonad (Label, STerm) + simplifyAssign (Ass lbl term) = liftM ((,) lbl) $ simplifyTerm term + + simplifyCase :: Case -> [CnvMonad (STerm, STerm)] + simplifyCase (Cas pats term) = [ liftM2 (,) (simplifyPattern pat) (simplifyTerm term) | + pat <- pats ] + + simplifyPattern :: Patt -> CnvMonad STerm + simplifyPattern (PC con pats) = liftM (SCon con) $ mapM simplifyPattern pats + simplifyPattern (PW) = return SWildcard + simplifyPattern (PR record) = do record' <- mapM simplifyPattAssign record + case filter (\row -> snd row /= SWildcard) record' of + [] -> return SWildcard + record'' -> return (SRec record') + simplifyPattern x = error $ "simplifyPattern: " ++ show x +-- error constructors: +-- (PV Ident) - pattern variable + + simplifyPattAssign :: PattAssign -> CnvMonad (Label, STerm) + simplifyPattAssign (PAss lbl pat) = liftM ((,) lbl) $ simplifyPattern pat + + +------------------------------------------------------------ +-- reducing simplified terms, collecting mcf rules + +reduceT :: Env -> CType -> STerm -> Path -> CnvMonad () +reduceT env = reduce + where + reduce :: CType -> STerm -> Path -> CnvMonad () + reduce TStr term path = updateLin (path, term) + reduce (Cn _) term path + = do pat <- expandTerm env term + updateHead (path, pat) + reduce ctype (SVariants terms) path + = do term <- member terms + reduce ctype term path + reduce (RecType rtype) term path + = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) | + Lbg lbl ctype <- rtype ] + reduce (Table _ ctype) (STbl table) path + = sequence_ [ reduce ctype term (path ++! pat) | + (pat, term) <- table ] + reduce (Table ptype vtype) arg@(SArg _ _ _) path + = sequence_ [ reduce vtype (arg +! pat) (path ++! pat) | + pat <- groundTerms env ptype ] + reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++ + ")\n term = (" ++ show term ++ + ")\n path = (" ++ show path ++ ")\n") + + +------------------------------------------------------------ +-- expanding a term to ground terms + +expandTerm :: Env -> STerm -> CnvMonad STerm +expandTerm env arg@(SArg _ _ _) + = do pat <- member $ groundTerms env $ cTypeForArg env arg + pat =?= arg + return pat +expandTerm env (SCon con terms) = liftM (SCon con) $ mapM (expandTerm env) terms +expandTerm env (SRec record) = liftM SRec $ mapM (expandAssign env) record +expandTerm env (SVariants terms) = member terms >>= expandTerm env +expandTerm env term = error $ "expandTerm: " ++ show term + +expandAssign :: Env -> (Label, STerm) -> CnvMonad (Label, STerm) +expandAssign env (lbl, term) = liftM ((,) lbl) $ expandTerm env term + +------------------------------------------------------------ +-- unification of patterns and selection terms + +(=?=) :: STerm -> STerm -> CnvMonad () +SWildcard =?= _ = return () +SRec precord =?= arg@(SArg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | + (lbl, pat) <- precord ] +pat =?= SArg arg _ path = updateArg arg (path, pat) +SCon con pats =?= SCon con' terms = do guard (con==con' && length pats==length terms) + sequence_ $ zipWith (=?=) pats terms +SRec precord =?= SRec record = sequence_ [ maybe mzero (pat =?=) mterm | + (lbl, pat) <- precord, + let mterm = lookup lbl record ] +pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term + + +------------------------------------------------------------ +-- updating the mcf rule + +updateArg :: Int -> Constraint -> CnvMonad () +updateArg arg cn + = do (head, args, lins) <- readState + args' <- updateNth (addToMCFCat cn) arg args + writeState (head, args', lins) + +updateHead :: Constraint -> CnvMonad () +updateHead cn + = do (head, args, lins) <- readState + head' <- addToMCFCat cn head + writeState (head', args, lins) + +updateLin :: Constraint -> CnvMonad () +updateLin (path, term) + = do let newLins = term2lins term + (head, args, lins) <- readState + let lins' = lins ++ map (Lin path) newLins + writeState (head, args, lins') + +term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]] +term2lins (SArg arg cat path) = return [Cat (cat, path, arg)] +term2lins (SToken str) = return [Tok str] +term2lins (SConcat t1 t2) = liftM2 (++) (term2lins t1) (term2lins t2) +term2lins (SEmpty) = return [] +term2lins (SVariants terms) = terms >>= term2lins +term2lins term = error $ "term2lins: " ++ show term + +addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat +addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat cat) $ addConstraint cn cns + +addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] +addConstraint cn0 (cn : cns) + | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) + | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> + return (cn : cns) +addConstraint cn0 cns = return (cn0 : cns) + + +---------------------------------------------------------------------- +-- utilities + +updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a] +updateNth update 0 (a : as) = liftM (:as) (update a) +updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as) + +catOfArg (A aCat _) = aCat +catOfArg (AB aCat _ _) = aCat + +lookupCType :: Env -> Cat -> CType +lookupCType env cat = errVal defLinType $ + lookupLincat (fst env) (CIQ (snd env) cat) + +groundTerms :: Env -> CType -> [STerm] +groundTerms env ctype = err error (map term2spattern) $ + allParamValues (fst env) ctype + +cTypeForArg :: Env -> STerm -> CType +cTypeForArg env (SArg nr cat (Path path)) + = follow path $ lookupCType env cat + where follow [] ctype = ctype + follow (Right pat : path) (Table _ ctype) = follow path ctype + follow (Left lbl : path) (RecType rec) + = case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of + [ctype] -> follow path ctype + err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ + " results in " ++ show err + +term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ] +term2spattern (Par con terms) = SCon con $ map term2spattern terms + diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs new file mode 100644 index 000000000..8b9b4a9ec --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Old.hs @@ -0,0 +1,277 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGFCtoMCFG.Old +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:18 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Converting GFC grammars to MCFG grammars. (Old variant) +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +-- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertGFCtoMCFG.Old (convertGrammar) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +--import PrintGFC +import qualified GF.Grammar.PrGrammar as PG + +import Control.Monad (liftM, liftM2, guard) +-- import Maybe (listToMaybe) +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.Look +import GF.Data.Operations +import qualified GF.Infra.Modules as M +import GF.Canon.CMacros (defLinType) +import GF.Canon.MkGFC (grammar2canon) +import GF.OldParsing.Utilities +import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) +import GF.Data.SortedList (nubsort, groupPairs) +import Data.Maybe (listToMaybe) +import Data.List (groupBy, transpose) + +---------------------------------------------------------------------- +-- old style types + +data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show) +type XMCFLabel = XPath + +cnvXMCFCat :: XMCFCat -> MCFCat +cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) | + (path, term) <- constrs ] + +cnvXMCFLabel :: XMCFLabel -> MCFLabel +cnvXMCFLabel = cnvXPath + +cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn +cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $ + map (mapSymbol cnvSym id) lin + where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr) + +-- Term -> STerm + +cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ] +cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) | + Cas pats term <- tbl, pat <- pats ] +cnvTerm (Par con terms) = SCon con $ map cnvTerm terms +cnvTerm term + | isArgPath term = cnvArgPath term + +cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ] +cnvPattern (PC con pats) = SCon con $ map cnvPattern pats +cnvPattern (PW) = SWildcard + +isArgPath (Arg _) = True +isArgPath (P _ _) = True +isArgPath (S _ _) = True +isArgPath _ = False + +cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath +cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl +cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel + +-- old style paths + +newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show) + +cnvXPath :: XPath -> Path +cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path)) + +emptyXPath :: XPath +emptyXPath = XPath [] + +(++..) :: XPath -> Label -> XPath +XPath path ++.. lbl = XPath (Left lbl : path) + +(++!!) :: XPath -> Term -> XPath +XPath path ++!! sel = XPath (Right sel : path) + +---------------------------------------------------------------------- + +-- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis +convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar +convertGrammar (gram, lng) = trace2 "language" (prt lng) $ + trace2 "modules" (prtSep " " modnames) $ + trace2 "#lin-terms" (prt (length cncdefs)) $ + tracePrt "#mcf-rules total" (prt.length) $ + concat $ + tracePrt "#mcf-rules per fun" + (\rs -> concat [" "++show n++"="++show (length r) | + (n, r) <- zip [1..] rs]) $ + map (convertDef gram lng) cncdefs + where Gr mods = grammar2canon gram + cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods, + modname `elem` modnames, + def@(CncDFun _ _ _ _ _) <- defs ] + modnames = M.allExtends gram lng + + +convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule] +convertDef gram lng (CncDFun fun (CIQ _ cat) args term _) + = [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun | + let ctype = lookupCType gram lng cat, + instArgs <- mapM (enumerateInsts gram lng) args, + let instTerm = substitutePaths gram lng instArgs term, + newCat <- emcfCat gram lng cat instTerm, + newArgs <- mapM (extractArg gram lng instArgs) args, + let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm + ] + + +-- gammalt skräp: +-- mergeArgs = zipWith mergeRec +-- mergeRec (R r1) (R r2) = R (r1 ++ r2) + +extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat] +extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr) + + +emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat] +emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat) + + +extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn] +extractLin args (path, term) = map (Lin path) (convertLin term) + where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2) + convertLin (E) = [[]] + convertLin (K tok) = [[Tok tok]] + convertLin (FV terms) = concatMap convertLin terms + convertLin term = map (return . Cat) $ flattenTerm emptyXPath term + flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)] + flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term + flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term + flattenTerm path (FV terms) = concatMap (flattenTerm path) terms + flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term + + +enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term] +enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat) + where enumerate path (TStr) = [ path ] + enumerate path (Cn con) = okError $ lookupParamValues gram con + enumerate path (RecType r) + = map R $ sequence [ map (lbl `Ass`) $ + enumerate (path `P` lbl) ctype | + lbl `Lbg` ctype <- r ] + enumerate path (Table s t) + = map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $ + enumerate (path `S` sel) t | + sel <- enumerate (error "enumerate") s ] + + + +termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))] +termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ] +termPaths gr l (RecType rtype) (R record) + = [ (path ++.. lbl, value) | + lbl `Ass` term <- record, + let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype, + (path, value) <- termPaths gr l ctype term ] +termPaths gr l (Table _ ctype) (T _ table) + = [ (path ++!! pattern2term pat, value) | + pats `Cas` term <- table, pat <- pats, + (path, value) <- termPaths gr l ctype term ] +termPaths gr l (Table _ ctype) (V ptype table) + = [ (path ++!! pat, value) | + (pat, term) <- zip (okError $ allParamValues gr ptype) table, + (path, value) <- termPaths gr l ctype term ] +termPaths gr l ctype (FV terms) + = concatMap (termPaths gr l ctype) terms +termPaths gr l (Cn pc) term = [ (emptyXPath, (Cn pc, term)) ] + +{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): +{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} +[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] +-} + +parPaths :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]] +parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths) + where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ] + +strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)] +strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] + where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ] + + +-- Substitute each instantiated parameter path for its instantiation +substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term +substitutePaths gr l arguments trm = subst trm + where subst (con `Par` terms) = con `Par` map subst terms + subst (R record) = R $ map substAss record + subst (term `P` lbl) = subst term `evalP` lbl + subst (T ptype table) = T ptype $ map substCas table + subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term | + (pat, term) <- zip (okError $ allParamValues gr ptype) table ] + subst (term `S` select) = subst term `evalS` subst select + subst (term `C` term') = subst term `C` subst term' + subst (FV terms) = evalFV $ map subst terms + subst (Arg (A _ arg)) = arguments !!! arg + subst term = term + + substAss (l `Ass` term) = l `Ass` subst term + substCas (p `Cas` term) = p `Cas` subst term + + +evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record + where errStr = "evalP: " ++ prt (R record `P` lbl) +evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ] +evalP term lbl = term `P` lbl + +evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl +evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ] +evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ] +evalS term sel = term `S` sel + +evalFV terms0 = case nubsort (concatMap flattenFV terms0) of + [term] -> term + terms -> FV terms + where flattenFV (FV ts) = ts + flattenFV t = [t] + + +---------------------------------------------------------------------- +-- utilities + +-- lookup a CType for an Ident +lookupCType :: CanonGrammar -> Ident -> Ident -> CType +lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c) + +-- lookup a label in a (record / record ctype / table) +lookupAssign :: Label -> [Assign] -> Maybe Term +lookupLabelling :: Label -> [Labelling] -> Maybe CType +lookupCase :: Term -> [Case] -> Maybe Term + +lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ] +lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] +lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ] + +matchesPats :: Term -> [Patt] -> Bool +matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ] + +-- converting between patterns and terms +pattern2term :: Patt -> Term +term2pattern :: Term -> Patt + +pattern2term (con `PC` patterns) = con `Par` map pattern2term patterns +pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern | + lbl `PAss` pattern <- record ] + +term2pattern (con `Par` terms) = con `PC` map term2pattern terms +term2pattern (R record) = PR [ lbl `PAss` term2pattern term | + lbl `Ass` term <- record ] + +-- list lookup for Integers instead of Ints +(!!!) :: [a] -> Integer -> a +xs !!! n = xs !! fromInteger n diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs new file mode 100644 index 000000000..d088bdebc --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGFCtoMCFG/Strict.hs @@ -0,0 +1,189 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGFCtoMCFG.Strict +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:18 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Converting GFC grammars to MCFG grammars, nondeterministically. +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +-- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertGFCtoMCFG.Strict (convertGrammar) where + +import GF.System.Tracing +-- import IOExts (unsafePerformIO) +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +-- import PrintGFC +-- import qualified PrGrammar as PG + +import Control.Monad +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.Look +import GF.Data.Operations +import qualified GF.Infra.Modules as M +import GF.Canon.CMacros (defLinType) +import GF.Canon.MkGFC (grammar2canon) +import GF.OldParsing.Utilities +import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..)) +import GF.Data.SortedList +-- import Maybe (listToMaybe) +import Data.List (groupBy) -- , transpose) + +import GF.Data.BacktrackM + +---------------------------------------------------------------------- + +type Env = (CanonGrammar, Ident) + +convertGrammar :: Env -- ^ the canonical grammar, together with the selected language + -> MCFGrammar -- ^ the resulting MCF grammar +convertGrammar gram = trace2 "language" (prt (snd gram)) $ + trace2 "modules" (prtSep " " modnames) $ + tracePrt "#mcf-rules total" (prt . length) $ + solutions conversion undefined + where Gr modules = grammar2canon (fst gram) + modnames = uncurry M.allExtends gram + conversion = member modules >>= convertModule + convertModule (Mod (MTCnc modname _) _ _ _ defs) + | modname `elem` modnames = member defs >>= convertDef gram + convertModule _ = failure + +convertDef :: Env -> Def -> CnvMonad MCFRule +convertDef env (CncDFun fun (CIQ _ cat) args term _) + | trace2 "converting function" (prt fun) True + = do let ctype = lookupCType env cat + instArgs <- mapM (enumerateArg env) args + let instTerm = substitutePaths env instArgs term + newCat <- emcfCat env cat instTerm + newArgs <- mapM (extractArg env instArgs) args + let newTerm = strPaths env ctype instTerm >>= extractLin newArgs + return (Rule newCat newArgs newTerm fun) +convertDef _ _ = failure + +------------------------------------------------------------ + +type CnvMonad a = BacktrackM () a + +---------------------------------------------------------------------- +-- strict conversion + +extractArg :: Env -> [STerm] -> ArgVar -> CnvMonad MCFCat +extractArg env args (A cat nr) = emcfCat env cat (args !! fromInteger nr) + +emcfCat :: Env -> Cat -> STerm -> CnvMonad MCFCat +emcfCat env cat term = member $ map (MCFCat cat) $ parPaths env (lookupCType env cat) term + +enumerateArg :: Env -> ArgVar -> CnvMonad STerm +enumerateArg env (A cat nr) = let ctype = lookupCType env cat + in enumerate (SArg (fromInteger nr) cat emptyPath) ctype + where enumerate arg (TStr) = return arg + enumerate arg ctype@(Cn _) = member $ groundTerms env ctype + enumerate arg (RecType rtype) + = liftM SRec $ sequence [ liftM ((,) lbl) $ + enumerate (arg +. lbl) ctype | + lbl `Lbg` ctype <- rtype ] + enumerate arg (Table stype ctype) + = do state <- readState + liftM STbl $ sequence [ liftM ((,) sel) $ + enumerate (arg +! sel) ctype | + sel <- solutions (enumerate err stype) state ] + where err = error "enumerate: parameter type should not be string" + +-- Substitute each instantiated parameter path for its instantiation +substitutePaths :: Env -> [STerm] -> Term -> STerm +substitutePaths env arguments trm = subst trm + where subst (con `Par` terms) = con `SCon` map subst terms + subst (R record) = SRec [ (lbl, subst term) | lbl `Ass` term <- record ] + subst (term `P` lbl) = subst term +. lbl + subst (T ptype table) = STbl [ (pattern2sterm pat, subst term) | + pats `Cas` term <- table, pat <- pats ] + subst (V ptype table) = STbl [ (pat, subst term) | + (pat, term) <- zip (groundTerms env ptype) table ] + subst (term `S` select) = subst term +! subst select + subst (term `C` term') = subst term `SConcat` subst term' + subst (K str) = SToken str + subst (E) = SEmpty + subst (FV terms) = evalFV $ map subst terms + subst (Arg (A _ arg)) = arguments !! fromInteger arg + + +termPaths :: Env -> CType -> STerm -> [(Path, (CType, STerm))] +termPaths env (TStr) term = [ (emptyPath, (TStr, term)) ] +termPaths env (RecType rtype) (SRec record) + = [ (path ++. lbl, value) | + (lbl, term) <- record, + let ctype = lookupLabelling lbl rtype, + (path, value) <- termPaths env ctype term ] +termPaths env (Table _ ctype) (STbl table) + = [ (path ++! pat, value) | + (pat, term) <- table, + (path, value) <- termPaths env ctype term ] +termPaths env ctype (SVariants terms) + = terms >>= termPaths env ctype +termPaths env (Cn pc) term = [ (emptyPath, (Cn pc, term)) ] + +{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): +{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} +[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] +-} + +parPaths :: Env -> CType -> STerm -> [[(Path, STerm)]] +parPaths env ctype term = mapM (uncurry (map . (,))) (groupPairs paths) + where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths env ctype term ] + +strPaths :: Env -> CType -> STerm -> [(Path, STerm)] +strPaths env ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] + where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths env ctype term ] + +extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn] +extractLin args (path, term) = map (Lin path) (convertLin term) + where convertLin (t1 `SConcat` t2) = liftM2 (++) (convertLin t1) (convertLin t2) + convertLin (SEmpty) = [[]] + convertLin (SToken tok) = [[Tok tok]] + convertLin (SVariants terms) = concatMap convertLin terms + convertLin (SArg nr _ path) = [[Cat (args !! nr, path, nr)]] + +evalFV terms0 = case nubsort (concatMap flattenFV terms0) of + [term] -> term + terms -> SVariants terms + where flattenFV (SVariants ts) = ts + flattenFV t = [t] + +---------------------------------------------------------------------- +-- utilities + +lookupCType :: Env -> Cat -> CType +lookupCType env cat = errVal defLinType $ + lookupLincat (fst env) (CIQ (snd env) cat) + +lookupLabelling :: Label -> [Labelling] -> CType +lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of + [ctyp] -> ctyp + err -> error $ "lookupLabelling:" ++ show err + +groundTerms :: Env -> CType -> [STerm] +groundTerms env ctype = err error (map term2spattern) $ + allParamValues (fst env) ctype + +term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ] +term2spattern (Par con terms) = SCon con $ map term2spattern terms + +pattern2sterm :: Patt -> STerm +pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns +pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) | + lbl `PAss` pattern <- record ] + diff --git a/src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs b/src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs new file mode 100644 index 000000000..69a8b13c3 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGFCtoSimple.hs @@ -0,0 +1,122 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:18 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Converting GFC to SimpleGFC +-- +-- the conversion might fail if the GFC grammar has dependent or higher-order types +----------------------------------------------------------------------------- + +module GF.OldParsing.ConvertGFCtoSimple where + +import qualified GF.Canon.AbsGFC as A +import qualified GF.Infra.Ident as I +import GF.OldParsing.SimpleGFC + +import GF.Canon.GFC +import GF.Canon.MkGFC (grammar2canon) +import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat) +import qualified GF.Canon.CMacros as CMacros (defLinType) +import GF.Data.Operations (err, errVal) +import qualified GF.Infra.Modules as M + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm + +---------------------------------------------------------------------- + +type Env = (CanonGrammar, I.Ident) + +convertGrammar :: Env -> Grammar +convertGrammar gram = trace2 "language" (show (snd gram)) $ + tracePrt "#simple-rules total" (show . length) $ + [ convertAbsFun gram fun typing | + A.Mod (A.MTAbs modname) _ _ _ defs <- modules, + A.AbsDFun fun typing _ <- defs ] + where A.Gr modules = grammar2canon (fst gram) + +convertAbsFun :: Env -> I.Ident -> A.Exp -> Rule +convertAbsFun gram fun aTyping + = -- trace2 "absFun" (show fun) $ + Rule fun sTyping sTerm + where sTyping = convertTyping [] aTyping + sTerm = do lin <- lookupLin gram fun + return (convertTerm gram lin, convertCType gram cType) + cType = lookupCType gram sTyping + +convertTyping :: [Decl] -> A.Exp -> Typing +-- convertTyping env tp | trace2 "typing" (prt env ++ " / " ++ prt tp) False = undefined +convertTyping env (A.EProd x a b) + = convertTyping ((x ::: convertType [] a) : env) b +convertTyping env a = (convertType [] a, reverse env) + +convertType :: [Atom] -> A.Exp -> Type +-- convertType args tp | trace2 "type" (prt args ++ " / " ++ prt tp) False = undefined +convertType args (A.EApp a (A.EAtom at)) = convertType (convertAtom at : args) a +convertType args (A.EAtom at) = convertCat at :@ args + +convertAtom :: A.Atom -> Atom +convertAtom (A.AC con) = ACon con +convertAtom (A.AV var) = AVar var + +convertCat :: A.Atom -> Cat +convertCat (A.AC (A.CIQ _ cat)) = cat +convertCat at = error $ "convertCat: " ++ show at + +convertCType :: Env -> A.CType -> CType +convertCType gram (A.RecType rec) + = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ] +convertCType gram (A.Table ptype vtype) + = TblT (convertCType gram ptype) (convertCType gram vtype) +convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct +convertCType gram (A.TStr) = StrT +convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor" + +convertTerm :: Env -> A.Term -> Term +convertTerm gram (A.Arg arg) = convertArgVar arg +convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms +convertTerm gram (A.LI var) = Var var +convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ] +convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl +convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) | + (pat, term) <- zip (groundTerms gram ctype) terms ] +convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) | + A.Cas pats term <- tbl, pat <- pats ] +convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel +convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2 +convertTerm gram (A.FV terms) = Variants (map (convertTerm gram) terms) +convertTerm gram (A.K tok) = Token tok +convertTerm gram (A.E) = Empty +convertTerm gram (A.I con) = error "convertTerm: cannot handle 'I' constructor" +convertTerm gram (A.EInt int) = error "convertTerm: cannot handle 'EInt' constructor" + +convertArgVar :: A.ArgVar -> Term +convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath +convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath + +convertPatt (A.PC con pats) = con :^ map convertPatt pats +convertPatt (A.PV x) = Var x +convertPatt (A.PW) = Wildcard +convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ] +convertPatt (A.PI n) = error "convertPatt: cannot handle 'PI' constructor" + +---------------------------------------------------------------------- + +lookupLin gram fun = err fail Just $ + Look.lookupLin (fst gram) (A.CIQ (snd gram) fun) + +--lookupCType :: Env -> Typing -> CType +lookupCType env (cat :@ _, _) = errVal CMacros.defLinType $ + Look.lookupLincat (fst env) (A.CIQ (snd env) cat) + +groundTerms :: Env -> A.CType -> [A.Term] +groundTerms gram ctype = err error id $ + Look.allParamValues (fst gram) ctype + diff --git a/src-3.0/GF/OldParsing/ConvertGrammar.hs b/src-3.0/GF/OldParsing/ConvertGrammar.hs new file mode 100644 index 000000000..0dcd90770 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertGrammar.hs @@ -0,0 +1,44 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGrammar +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:45 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- All (?) grammar conversions which are used in GF +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertGrammar + (pInfo, emptyPInfo, + module GF.OldParsing.GrammarTypes + ) where + +import GF.Canon.GFC (CanonGrammar) +import GF.Canon.MkGFC (grammar2canon) +import GF.OldParsing.GrammarTypes +import GF.Infra.Ident (Ident(..)) +import GF.Infra.Option +import GF.System.Tracing + +-- import qualified GF.OldParsing.FiniteTypes.Calc as Fin +import qualified GF.OldParsing.ConvertGFCtoMCFG as G2M +import qualified GF.OldParsing.ConvertMCFGtoCFG as M2C +import qualified GF.OldParsing.MCFGrammar as MCFG +import qualified GF.OldParsing.CFGrammar as CFG + +pInfo :: Options -> CanonGrammar -> Ident -> PInfo +pInfo opts canon lng = PInfo mcfg cfg mcfp cfp + where mcfg = G2M.convertGrammar cnv (canon, lng) + cnv = maybe "nondet" id $ getOptVal opts gfcConversion + cfg = M2C.convertGrammar mcfg + mcfp = MCFG.pInfo mcfg + cfp = CFG.pInfo cfg + +emptyPInfo :: PInfo +emptyPInfo = PInfo [] [] (MCFG.pInfo []) (CFG.pInfo []) + diff --git a/src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs b/src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs new file mode 100644 index 000000000..58d141166 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertMCFGtoCFG.hs @@ -0,0 +1,52 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertMCFGtoCFG +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:46 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Converting MCFG grammars to (possibly overgenerating) CFG +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertMCFGtoCFG + (convertGrammar) where + +import GF.System.Tracing +import GF.Printing.PrintParser + +import Control.Monad +import GF.OldParsing.Utilities +import qualified GF.OldParsing.MCFGrammar as MCFG +import qualified GF.OldParsing.CFGrammar as CFG +import GF.OldParsing.GrammarTypes + +convertGrammar :: MCFGrammar -> CFGrammar +convertGrammar gram = tracePrt "#cf-rules" (prt.length) $ + concatMap convertRule gram + +convertRule :: MCFRule -> [CFRule] +convertRule (MCFG.Rule cat args record name) + = [ CFG.Rule (CFCat cat lbl) rhs (CFName name profile) | + MCFG.Lin lbl lin <- record, + let rhs = map (mapSymbol convertArg id) lin, + let profile = map (argPlaces lin) [0 .. length args-1] + ] + +convertArg (cat, lbl, _arg) = CFCat cat lbl + +argPlaces lin arg = [ place | ((_cat, _lbl, arg'), place) <- + zip (filterCats lin) [0::Int ..], arg == arg' ] + +filterCats syms = [ cat | Cat cat <- syms ] + + + + + + + diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs new file mode 100644 index 000000000..e111444f9 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG.hs @@ -0,0 +1,30 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/11 13:52:53 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.1 $ +-- +-- All different conversions from SimpleGFC to MCFG +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertSimpleToMCFG + (convertGrammar) where + +import qualified GF.OldParsing.SimpleGFC as S +--import GF.OldParsing.GrammarTypes + +import qualified GF.OldParsing.ConvertFiniteSimple as Fin +import qualified GF.OldParsing.ConvertSimpleToMCFG.Nondet as Nondet +--import qualified GF.OldParsing.ConvertSimpleToMCFG.Strict as Strict +import qualified GF.OldParsing.ConvertSimpleToMCFG.Coercions as Coerce + +--convertGrammar :: String -> S.Grammar -> MCFGrammar +convertGrammar ('f':'i':'n':'-':cnv) = convertGrammar cnv . Fin.convertGrammar +convertGrammar "nondet" = Coerce.addCoercions . Nondet.convertGrammar +--convertGrammar "strict" = Strict.convertGrammar + diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs new file mode 100644 index 000000000..adc42115a --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs @@ -0,0 +1,70 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:57 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Adding coercion functions to a MCFG if necessary. +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertSimpleToMCFG.Coercions (addCoercions) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +-- import PrintGFC +-- import qualified PrGrammar as PG + +import qualified GF.Infra.Ident as Ident +import GF.OldParsing.Utilities +--import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) +import GF.Data.SortedList +import Data.List (groupBy) -- , transpose) + +---------------------------------------------------------------------- + +--addCoercions :: MCFGrammar -> MCFGrammar +addCoercions rules = coercions ++ rules + where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | + Rule head args lins _ <- rules, + let lbls = [ lbl | Lin lbl _ <- lins ] ] + allHeadSet = nubsort allHeads + allArgSet = union allArgs <\\> map fst allHeadSet + coercions = tracePrt "#coercions total" (prt . length) $ + concat $ + tracePrt "#coercions per cat" (prtList . map length) $ + combineCoercions + (groupBy sameCatFst allHeadSet) + (groupBy sameCat allArgSet) + sameCatFst a b = sameCat (fst a) (fst b) + + +combineCoercions [] _ = [] +combineCoercions _ [] = [] +combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) + = case compare (mainCat $ fst $ head heads) (mainCat $ head args) of + LT -> combineCoercions allHeads allArgs' + GT -> combineCoercions allHeads' allArgs + EQ -> makeCoercion heads args : combineCoercions allHeads allArgs + + +makeCoercion heads args = [ Rule arg [head] lins coercionName | + head@((_, headCns), lbls) <- heads, + let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], + arg@(_, argCns) <- args, + argCns `subset` headCns ] + + +coercionName = Ident.IW + +mainCat (c, _) = c + +sameCat mc1 mc2 = mainCat mc1 == mainCat mc2 + + diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs new file mode 100644 index 000000000..6627c5f2e --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs @@ -0,0 +1,245 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:58 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertSimpleToMCFG.Nondet (convertGrammar) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +-- import PrintGFC +-- import qualified PrGrammar as PG + +import Control.Monad +-- import Ident (Ident(..)) +import qualified GF.Canon.AbsGFC as AbsGFC +-- import GFC +import GF.Canon.Look +import GF.Data.Operations +-- import qualified Modules as M +import GF.Canon.CMacros (defLinType) +-- import MkGFC (grammar2canon) +import GF.OldParsing.Utilities +-- import GF.OldParsing.GrammarTypes +import GF.Data.SortedList +import qualified GF.OldParsing.MCFGrammar as MCF (Grammar, Rule(..), Lin(..)) +import GF.OldParsing.SimpleGFC +-- import Maybe (listToMaybe) +import Data.List (groupBy) -- , transpose) + +import GF.Data.BacktrackM + +---------------------------------------------------------------------- + +--convertGrammar :: Grammar -> MCF.Grammar +convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $ + solutions conversion rules undefined + where conversion = member rules >>= convertRule + +--convertRule :: Rule -> CnvMonad MCF.Rule +convertRule (Rule fun (cat :@ _, decls) (Just (term, ctype))) + = do let args = [ arg | _ ::: (arg :@ _) <- decls ] + writeState (initialMCat cat, map initialMCat args, []) + convertTerm cat term + (newCat, newArgs, linRec) <- readState + let newTerm = map (instLin newArgs) linRec + return (MCF.Rule newCat newArgs newTerm fun) +convertRule _ = failure + +instLin newArgs (MCF.Lin lbl lin) = MCF.Lin lbl (map instSym lin) + where instSym = mapSymbol instCat id + instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg) + +--convertTerm :: Cat -> Term -> CnvMonad () +convertTerm cat term = do rterm <- simplifyTerm term + env <- readEnv + let ctype = lookupCType env cat + reduce ctype rterm emptyPath + +------------------------------------------------------------ + +{- +type CnvMonad a = BacktrackM Grammar CMRule a + +type CMRule = (MCFCat, [MCFCat], LinRec) +type LinRec = [Lin Cat Path Tokn] +-} + +--initialMCat :: Cat -> MCFCat +initialMCat cat = (cat, []) --MCFCat cat [] + +---------------------------------------------------------------------- + +--simplifyTerm :: Term -> CnvMonad STerm +simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms +simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record +simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term +simplifyTerm (Tbl table) = Tbl $ mapM simplifyCase table +simplifyTerm (term :! sel) + = do sterm <- simplifyTerm term + ssel <- simplifyTerm sel + case sterm of + Tbl table -> do (pat, val) <- member table + pat =?= ssel + return val + _ -> do sel' <- expandTerm ssel + return (sterm +! sel') +simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms +simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2) +simplifyTerm term = return term +-- error constructors: +-- (I CIdent) - from resource +-- (LI Ident) - pattern variable +-- (EInt Integer) - integer + +--simplifyAssign :: Assign -> CnvMonad (Label, STerm) +simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term + +--simplifyCase :: Case -> [CnvMonad (STerm, STerm)] +simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) + + +------------------------------------------------------------ +-- reducing simplified terms, collecting mcf rules + +--reduce :: CType -> STerm -> Path -> CnvMonad () +reduce StrT term path = updateLin (path, term) +reduce (ConT _) term path + = do pat <- expandTerm term + updateHead (path, pat) +reduce ctype (Variants terms) path + = do term <- member terms + reduce ctype term path +reduce (RecT rtype) term path + = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) | + (lbl, ctype) <- rtype ] +reduce (TblT _ ctype) (Tbl table) path + = sequence_ [ reduce ctype term (path ++! pat) | + (pat, term) <- table ] +reduce (TblT ptype vtype) arg@(Arg _ _ _) path + = do env <- readEnv + sequence_ [ reduce vtype (arg +! pat) (path ++! pat) | + pat <- groundTerms ptype ] +reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++ + ")\n term = (" ++ show term ++ + ")\n path = (" ++ show path ++ ")\n") + + +------------------------------------------------------------ +-- expanding a term to ground terms + +--expandTerm :: STerm -> CnvMonad STerm +expandTerm arg@(Arg _ _ _) + = do env <- readEnv + pat <- member $ groundTerms $ cTypeForArg env arg + pat =?= arg + return pat +expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms +expandTerm (Rec record) = liftM Rec $ mapM expandAssign record +expandTerm (Variants terms) = member terms >>= expandTerm +expandTerm term = error $ "expandTerm: " ++ show term + +--expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) +expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term + +------------------------------------------------------------ +-- unification of patterns and selection terms + +--(=?=) :: STerm -> STerm -> CnvMonad () +Wildcard =?= _ = return () +Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | + (lbl, pat) <- precord ] +pat =?= Arg arg _ path = updateArg arg (path, pat) +(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms) + sequence_ $ zipWith (=?=) pats terms +Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm | + (lbl, pat) <- precord, + let mterm = lookup lbl record ] +pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term + + +------------------------------------------------------------ +-- updating the mcf rule + +--updateArg :: Int -> Constraint -> CnvMonad () +updateArg arg cn + = do (head, args, lins) <- readState + args' <- updateNth (addToMCFCat cn) arg args + writeState (head, args', lins) + +--updateHead :: Constraint -> CnvMonad () +updateHead cn + = do (head, args, lins) <- readState + head' <- addToMCFCat cn head + writeState (head', args, lins) + +--updateLin :: Constraint -> CnvMonad () +updateLin (path, term) + = do let newLins = term2lins term + (head, args, lins) <- readState + let lins' = lins ++ map (MCF.Lin path) newLins + writeState (head, args, lins') + +--term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]] +term2lins (Arg arg cat path) = return [Cat (cat, path, arg)] +term2lins (Token str) = return [Tok str] +term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2) +term2lins (Empty) = return [] +term2lins (Variants terms) = terms >>= term2lins +term2lins term = error $ "term2lins: " ++ show term + +--addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat +addToMCFCat cn ({-MCFCat-} cat, cns) = liftM ({-MCFCat-} (,) cat) $ addConstraint cn cns + +--addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] +addConstraint cn0 (cn : cns) + | fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns) + | fst cn0 == fst cn = guard (snd cn0 == snd cn) >> + return (cn : cns) +addConstraint cn0 cns = return (cn0 : cns) + + +---------------------------------------------------------------------- +-- utilities + +updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a] +updateNth update 0 (a : as) = liftM (:as) (update a) +updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as) + +--lookupCType :: GrammarEnv -> Cat -> CType +lookupCType env cat = errVal defLinType $ + lookupLincat (fst env) (AbsGFC.CIQ (snd env) cat) + +--groundTerms :: GrammarEnv -> CType -> [STerm] +groundTerms env ctype = err error (map term2spattern) $ + allParamValues (fst env) ctype + +--cTypeForArg :: GrammarEnv -> STerm -> CType +cTypeForArg env (Arg nr cat (Path path)) + = follow path $ lookupCType env cat + where follow [] ctype = ctype + follow (Right pat : path) (TblT _ ctype) = follow path ctype + follow (Left lbl : path) (RecT rec) + = case [ ctype | (lbl', ctype) <- rec, lbl == lbl' ] of + [ctype] -> follow path ctype + err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ + " results in " ++ show err + +term2spattern (AbsGFC.R rec) = Rec [ (lbl, term2spattern term) | + AbsGFC.Ass lbl term <- rec ] +term2spattern (AbsGFC.Con con terms) = con :^ map term2spattern terms + diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs new file mode 100644 index 000000000..dd2ff0713 --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs @@ -0,0 +1,277 @@ +---------------------------------------------------------------------- +-- | +-- Module : ConvertGFCtoMCFG.Old +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:59 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Converting GFC grammars to MCFG grammars. (Old variant) +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +-- (also, the conversion might fail if the GFC grammar has dependent or higher-order types) +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertSimpleToMCFG.Old (convertGrammar) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm +--import PrintGFC +import qualified GF.Grammar.PrGrammar as PG + +import Control.Monad (liftM, liftM2, guard) +-- import Maybe (listToMaybe) +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.Look +import GF.Data.Operations +import qualified GF.Infra.Modules as M +import GF.Canon.CMacros (defLinType) +import GF.Canon.MkGFC (grammar2canon) +import GF.OldParsing.Utilities +import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Rule(..), Lin(..)) +import GF.Data.SortedList (nubsort, groupPairs) +import Data.Maybe (listToMaybe) +import Data.List (groupBy, transpose) + +---------------------------------------------------------------------- +-- old style types + +data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show) +type XMCFLabel = XPath + +cnvXMCFCat :: XMCFCat -> MCFCat +cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) | + (path, term) <- constrs ] + +cnvXMCFLabel :: XMCFLabel -> MCFLabel +cnvXMCFLabel = cnvXPath + +cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn +cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $ + map (mapSymbol cnvSym id) lin + where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr) + +-- Term -> STerm + +cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ] +cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) | + Cas pats term <- tbl, pat <- pats ] +cnvTerm (Con con terms) = SCon con $ map cnvTerm terms +cnvTerm term + | isArgPath term = cnvArgPath term + +cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ] +cnvPattern (PC con pats) = SCon con $ map cnvPattern pats +cnvPattern (PW) = SWildcard + +isArgPath (Arg _) = True +isArgPath (P _ _) = True +isArgPath (S _ _) = True +isArgPath _ = False + +cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath +cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl +cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel + +-- old style paths + +newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show) + +cnvXPath :: XPath -> Path +cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path)) + +emptyXPath :: XPath +emptyXPath = XPath [] + +(++..) :: XPath -> Label -> XPath +XPath path ++.. lbl = XPath (Left lbl : path) + +(++!!) :: XPath -> Term -> XPath +XPath path ++!! sel = XPath (Right sel : path) + +---------------------------------------------------------------------- + +-- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis +convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar +convertGrammar (gram, lng) = trace2 "language" (prt lng) $ + trace2 "modules" (prtSep " " modnames) $ + trace2 "#lin-terms" (prt (length cncdefs)) $ + tracePrt "#mcf-rules total" (prt.length) $ + concat $ + tracePrt "#mcf-rules per fun" + (\rs -> concat [" "++show n++"="++show (length r) | + (n, r) <- zip [1..] rs]) $ + map (convertDef gram lng) cncdefs + where Gr mods = grammar2canon gram + cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods, + modname `elem` modnames, + def@(CncDFun _ _ _ _ _) <- defs ] + modnames = M.allExtends gram lng + + +convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule] +convertDef gram lng (CncDFun fun (CIQ _ cat) args term _) + = [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun | + let ctype = lookupCType gram lng cat, + instArgs <- mapM (enumerateInsts gram lng) args, + let instTerm = substitutePaths gram lng instArgs term, + newCat <- emcfCat gram lng cat instTerm, + newArgs <- mapM (extractArg gram lng instArgs) args, + let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm + ] + + +-- gammalt skräp: +-- mergeArgs = zipWith mergeRec +-- mergeRec (R r1) (R r2) = R (r1 ++ r2) + +extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat] +extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr) + + +emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat] +emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat) + + +extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn] +extractLin args (path, term) = map (Lin path) (convertLin term) + where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2) + convertLin (E) = [[]] + convertLin (K tok) = [[Tok tok]] + convertLin (FV terms) = concatMap convertLin terms + convertLin term = map (return . Cat) $ flattenTerm emptyXPath term + flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)] + flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term + flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term + flattenTerm path (FV terms) = concatMap (flattenTerm path) terms + flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term + + +enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term] +enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat) + where enumerate path (TStr) = [ path ] + enumerate path (Cn con) = okError $ lookupParamValues gram con + enumerate path (RecType r) + = map R $ sequence [ map (lbl `Ass`) $ + enumerate (path `P` lbl) ctype | + lbl `Lbg` ctype <- r ] + enumerate path (Table s t) + = map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $ + enumerate (path `S` sel) t | + sel <- enumerate (error "enumerate") s ] + + + +termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))] +termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ] +termPaths gr l (RecType rtype) (R record) + = [ (path ++.. lbl, value) | + lbl `Ass` term <- record, + let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype, + (path, value) <- termPaths gr l ctype term ] +termPaths gr l (Table _ ctype) (T _ table) + = [ (path ++!! pattern2term pat, value) | + pats `Cas` term <- table, pat <- pats, + (path, value) <- termPaths gr l ctype term ] +termPaths gr l (Table _ ctype) (V ptype table) + = [ (path ++!! pat, value) | + (pat, term) <- zip (okError $ allParamValues gr ptype) table, + (path, value) <- termPaths gr l ctype term ] +termPaths gr l ctype (FV terms) + = concatMap (termPaths gr l ctype) terms +termPaths gr l (Cn pc) term = [ (emptyXPath, (Cn pc, term)) ] + +{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): +{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} +[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] +-} + +parPaths :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]] +parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths) + where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ] + +strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)] +strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ] + where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ] + + +-- Substitute each instantiated parameter path for its instantiation +substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term +substitutePaths gr l arguments trm = subst trm + where subst (con `Con` terms) = con `Con` map subst terms + subst (R record) = R $ map substAss record + subst (term `P` lbl) = subst term `evalP` lbl + subst (T ptype table) = T ptype $ map substCas table + subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term | + (pat, term) <- zip (okError $ allParamValues gr ptype) table ] + subst (term `S` select) = subst term `evalS` subst select + subst (term `C` term') = subst term `C` subst term' + subst (FV terms) = evalFV $ map subst terms + subst (Arg (A _ arg)) = arguments !!! arg + subst term = term + + substAss (l `Ass` term) = l `Ass` subst term + substCas (p `Cas` term) = p `Cas` subst term + + +evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record + where errStr = "evalP: " ++ prt (R record `P` lbl) +evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ] +evalP term lbl = term `P` lbl + +evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl +evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ] +evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ] +evalS term sel = term `S` sel + +evalFV terms0 = case nubsort (concatMap flattenFV terms0) of + [term] -> term + terms -> FV terms + where flattenFV (FV ts) = ts + flattenFV t = [t] + + +---------------------------------------------------------------------- +-- utilities + +-- lookup a CType for an Ident +lookupCType :: CanonGrammar -> Ident -> Ident -> CType +lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c) + +-- lookup a label in a (record / record ctype / table) +lookupAssign :: Label -> [Assign] -> Maybe Term +lookupLabelling :: Label -> [Labelling] -> Maybe CType +lookupCase :: Term -> [Case] -> Maybe Term + +lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ] +lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] +lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ] + +matchesPats :: Term -> [Patt] -> Bool +matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ] + +-- converting between patterns and terms +pattern2term :: Patt -> Term +term2pattern :: Term -> Patt + +pattern2term (con `PC` patterns) = con `Con` map pattern2term patterns +pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern | + lbl `PAss` pattern <- record ] + +term2pattern (con `Con` terms) = con `PC` map term2pattern terms +term2pattern (R record) = PR [ lbl `PAss` term2pattern term | + lbl `Ass` term <- record ] + +-- list lookup for Integers instead of Ints +(!!!) :: [a] -> Integer -> a +xs !!! n = xs !! fromInteger n diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs new file mode 100644 index 000000000..aa741518a --- /dev/null +++ b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs @@ -0,0 +1,139 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:00 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Converting SimpleGFC grammars to MCFG grammars, deterministic. +-- +-- the resulting grammars might be /very large/ +-- +-- the conversion is only equivalent if the GFC grammar has a context-free backbone. +----------------------------------------------------------------------------- + + +module GF.OldParsing.ConvertSimpleToMCFG.Strict (convertGrammar) where + +import GF.System.Tracing +import GF.Infra.Print + +import Control.Monad + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.SimpleGFC +import GF.Conversion.Types + +import GF.Data.BacktrackM + +{- +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +import GF.Canon.GFC +import GF.Canon.Look +import GF.Data.Operations +import qualified GF.Infra.Modules as M +import GF.Canon.CMacros (defLinType) +import GF.Canon.MkGFC (grammar2canon) +import GF.OldParsing.Utilities +import GF.OldParsing.GrammarTypes +import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..)) +import GF.Data.SortedList +-- import Maybe (listToMaybe) +import Data.List (groupBy) -- , transpose) + +import GF.Data.BacktrackM +-} + +---------------------------------------------------------------------- + +convertGrammar :: SimpleGrammar -> MGrammar +convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $ + solutions conversion undefined + where conversion = member rules >>= convertRule + +convertRule :: SimpleRule -> CnvMonad MRule +convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) + = do let cat : args = map decl2cat (decl : decls) + args_ctypes = zip3 [0..] args ctypes + instArgs <- mapM enumerateArg args_ctypes + let instTerm = substitutePaths instArgs term + newCat <- extractMCat cat ctype instTerm + newArgs <- mapM (extractArg instArgs) args + let newLinRec = strPaths ctype instTerm >>= extractLin newArgs + lintype : lintypes = map (convertLinType emptyPath) (ctype : ctypes) + return $ Rule (Abs newCat newArgs fun) (Cnc lintype lintypes newLinRec) +convertRule _ = failure + +---------------------------------------------------------------------- + +type CnvMonad a = BacktrackM () a + +---------------------------------------------------------------------- +-- strict conversion + +--extractArg :: [Term] -> (Int, Cat, LinType) -> CnvMonad MCat +extractArg args (nr, cat, ctype) = emcfCat cat ctype (args !! nr) + +--emcfCat :: Cat -> LinType -> Term -> CnvMonad MCat +extractMCat cat ctype term = map (MCat cat) $ parPaths ctype term + +--enumerateArg :: (Int, Cat, LinType) -> CnvMonad Term +enumerateArg (nr, cat, ctype) = enumerateTerms (Arg nr cat emptyPath) ctype + +-- Substitute each instantiated parameter path for its instantiation +substitutePaths :: [Term] -> Term -> Term +substitutePaths arguments = subst + where subst (Arg nr _ path) = followPath path (arguments !! nr) + subst (con :^ terms) = con :^ map subst terms + subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ] + subst (term :. lbl) = subst term +. lbl + subst (Tbl table) = Tbl [ (pat, subst term) | + (pat, term) <- table ] + subst (term :! select) = subst term +! subst select + subst (term :++ term') = subst term ?++ subst term' + subst (Variants terms) = Variants $ map subst terms + subst term = term + + +--termPaths :: CType -> STerm -> [(Path, (CType, STerm))] +termPaths ctype (Variants terms) = terms >>= termPaths ctype +termPaths (StrT) term = [ (emptyPath, (StrT, term)) ] +termPaths (RecT rtype) (Rec record) + = [ (path ++. lbl, value) | + (lbl, term) <- record, + let Just ctype = lookup lbl rtype, + (path, value) <- termPaths ctype term ] +termPaths (TblT _ ctype) (Tbl table) + = [ (path ++! pat, value) | + (pat, term) <- table, + (path, value) <- termPaths ctype term ] +termPaths (ConT pc _) term = [ (emptyPath, (ConT pc, term)) ] + +{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt): +{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2} +[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] +-} + +--parPaths :: CType -> STerm -> [[(Path, STerm)]] +parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ + nubsort [ (path, value) | + (path, (ConT _, value)) <- termPaths ctype term ] + +--strPaths :: CType -> STerm -> [(Path, STerm)] +strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ] + where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ] + +--extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn] +extractLin args (path, term) = map (Lin path) (convertLin term) + where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2) + convertLin (Empty) = [[]] + convertLin (Token tok) = [[Tok tok]] + convertLin (Variants terms) = concatMap convertLin terms + convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]] + diff --git a/src-3.0/GF/OldParsing/GCFG.hs b/src-3.0/GF/OldParsing/GCFG.hs new file mode 100644 index 000000000..33a710e5d --- /dev/null +++ b/src-3.0/GF/OldParsing/GCFG.hs @@ -0,0 +1,43 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/11 13:52:53 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.1 $ +-- +-- Simplistic GFC format +----------------------------------------------------------------------------- + +module GF.OldParsing.GCFG where + +import GF.Printing.PrintParser + +---------------------------------------------------------------------- + +type Grammar c n l t = [Rule c n l t] +data Rule c n l t = Rule (Abstract c n) (Concrete l t) + deriving (Eq, Ord, Show) + +data Abstract cat name = Abs cat [cat] name + deriving (Eq, Ord, Show) +data Concrete lin term = Cnc lin [lin] term + deriving (Eq, Ord, Show) + +---------------------------------------------------------------------- + +instance (Print c, Print n, Print l, Print t) => Print (Rule n c l t) where + prt (Rule abs cnc) = prt abs ++ " := " ++ prt cnc ++ "\n" + prtList = concatMap prt + +instance (Print c, Print n) => Print (Abstract c n) where + prt (Abs cat args name) = prt name ++ ". " ++ prt cat ++ + ( if null args then "" + else " -> " ++ prtSep " " args ) + +instance (Print l, Print t) => Print (Concrete l t) where + prt (Cnc lcat args term) = prt term ++ " : " ++ prt lcat ++ + ( if null args then "" + else " [ " ++ prtSep " " args ++ " ]" ) diff --git a/src-3.0/GF/OldParsing/GeneralChart.hs b/src-3.0/GF/OldParsing/GeneralChart.hs new file mode 100644 index 000000000..1d51da025 --- /dev/null +++ b/src-3.0/GF/OldParsing/GeneralChart.hs @@ -0,0 +1,86 @@ +---------------------------------------------------------------------- +-- | +-- Module : GeneralChart +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/11 13:52:53 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.1 $ +-- +-- Simple implementation of deductive chart parsing +----------------------------------------------------------------------------- + + +module GF.OldParsing.GeneralChart + (-- * Type definition + Chart, + -- * Main functions + chartLookup, + buildChart, + -- * Probably not needed + emptyChart, + chartMember, + chartInsert, + chartList, + addToChart + ) where + +-- import Trace + +import GF.Data.RedBlackSet + +-- main functions + +chartLookup :: (Ord item, Ord key) => Chart item key -> key -> [item] +buildChart :: (Ord item, Ord key) => (item -> key) -> + [Chart item key -> item -> [item]] -> [item] -> [item] + +buildChart keyof rules axioms = chartList (addItems axioms emptyChart) + where addItems [] = id + addItems (item:items) = addItems items . addItem item + + -- addItem item | trace ("+ "++show item++"\n") False = undefined + addItem item = addToChart item (keyof item) + (\chart -> foldr (consequence item) chart rules) + + consequence item rule chart = addItems (rule chart item) chart + +-- probably not needed + +emptyChart :: (Ord item, Ord key) => Chart item key +chartMember :: (Ord item, Ord key) => Chart item key -> item -> key -> Bool +chartInsert :: (Ord item, Ord key) => Chart item key -> item -> key -> Maybe (Chart item key) +chartList :: (Ord item, Ord key) => Chart item key -> [item] +addToChart :: (Ord item, Ord key) => item -> key -> (Chart item key -> Chart item key) -> Chart item key -> Chart item key + +addToChart item key after chart = maybe chart after (chartInsert chart item key) + + +-------------------------------------------------------------------------------- +-- key charts as red/black trees + +newtype Chart item key = KC (RedBlackMap key item) + deriving Show + +emptyChart = KC rbmEmpty +chartMember (KC tree) item key = rbmElem key item tree +chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree) +chartLookup (KC tree) key = rbmLookup key tree +chartList (KC tree) = concatMap snd (rbmList tree) +--------------------------------------------------------------------------------} + + +{-------------------------------------------------------------------------------- +-- key charts as unsorted association lists -- OBSOLETE! + +newtype Chart item key = SC [(key, item)] + +emptyChart = SC [] +chartMember (SC chart) item key = (key,item) `elem` chart +chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart)) +chartLookup (SC chart) key = [ item | (key',item) <- chart, key == key' ] +chartList (SC chart) = map snd chart +--------------------------------------------------------------------------------} + diff --git a/src-3.0/GF/OldParsing/GrammarTypes.hs b/src-3.0/GF/OldParsing/GrammarTypes.hs new file mode 100644 index 000000000..fc514fc75 --- /dev/null +++ b/src-3.0/GF/OldParsing/GrammarTypes.hs @@ -0,0 +1,148 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:46 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- All possible instantiations of different grammar formats used for parsing +-- +-- Plus some helper types and utilities +----------------------------------------------------------------------------- + + +module GF.OldParsing.GrammarTypes + (-- * Main parser information + PInfo(..), + -- * Multiple context-free grammars + MCFGrammar, MCFRule, MCFPInfo, + MCFCat(..), MCFLabel, + Constraint, + -- * Context-free grammars + CFGrammar, CFRule, CFPInfo, + CFProfile, CFName(..), CFCat(..), + -- * Assorted types + Cat, Name, Constr, Label, Tokn, + -- * Simplified terms + STerm(..), (+.), (+!), + -- * Record\/table paths + Path(..), emptyPath, + (++.), (++!) + ) where + +import GF.Infra.Ident (Ident(..)) +import GF.Canon.AbsGFC +-- import qualified GF.OldParsing.FiniteTypes.Calc as Fin +import qualified GF.OldParsing.CFGrammar as CFG +import qualified GF.OldParsing.MCFGrammar as MCFG +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm + +import qualified GF.OldParsing.ConvertGFCtoSimple + +---------------------------------------------------------------------- + +data PInfo = PInfo { mcfg :: MCFGrammar, + cfg :: CFGrammar, + mcfPInfo :: MCFPInfo, + cfPInfo :: CFPInfo } + +type MCFGrammar = MCFG.Grammar Name MCFCat MCFLabel Tokn +type MCFRule = MCFG.Rule Name MCFCat MCFLabel Tokn +type MCFPInfo = MCFG.PInfo Name MCFCat MCFLabel Tokn + +data MCFCat = MCFCat Cat [Constraint] deriving (Eq, Ord, Show) +type MCFLabel = Path + +type Constraint = (Path, STerm) + +type CFGrammar = CFG.Grammar CFName CFCat Tokn +type CFRule = CFG.Rule CFName CFCat Tokn +type CFPInfo = CFG.PInfo CFName CFCat Tokn + +type CFProfile = [[Int]] +data CFName = CFName Name CFProfile deriving (Eq, Ord, Show) +data CFCat = CFCat MCFCat MCFLabel deriving (Eq, Ord, Show) + +---------------------------------------------------------------------- + +type Cat = Ident +type Name = Ident +type Constr = CIdent + +data STerm = SArg Int Cat Path -- ^ argument variable, the 'Path' is a path + -- pointing into the term + | SCon Constr [STerm] -- ^ constructor + | SRec [(Label, STerm)] -- ^ record + | STbl [(STerm, STerm)] -- ^ table of patterns\/terms + | SVariants [STerm] -- ^ variants + | SConcat STerm STerm -- ^ concatenation + | SToken Tokn -- ^ single token + | SEmpty -- ^ empty string + | SWildcard -- ^ wildcard pattern variable + + -- SRes CIdent -- resource identifier + -- SVar Ident -- bound pattern variable + -- SInt Integer -- integer + deriving (Eq, Ord, Show) + +(+.) :: STerm -> Label -> STerm +SRec record +. lbl = maybe err id $ lookup lbl record + where err = error $ "(+.), label not in record: " ++ show (SRec record) ++ " +. " ++ show lbl +SArg arg cat path +. lbl = SArg arg cat (path ++. lbl) +SVariants terms +. lbl = SVariants $ map (+. lbl) terms +sterm +. lbl = error $ "(+.): " ++ show sterm ++ " +. " ++ show lbl + +(+!) :: STerm -> STerm -> STerm +STbl table +! pat = maybe err id $ lookup pat table + where err = error $ "(+!), pattern not in table: " ++ show (STbl table) ++ " +! " ++ show pat +SArg arg cat path +! pat = SArg arg cat (path ++! pat) +SVariants terms +! pat = SVariants $ map (+! pat) terms +term +! SVariants pats = SVariants $ map (term +!) pats +sterm +! pat = error $ "(+!): " ++ show sterm ++ " +! " ++ show pat + +---------------------------------------------------------------------- + +newtype Path = Path [Either Label STerm] deriving (Eq, Ord, Show) + +emptyPath :: Path +emptyPath = Path [] + +(++.) :: Path -> Label -> Path +Path path ++. lbl = Path (Left lbl : path) + +(++!) :: Path -> STerm -> Path +Path path ++! sel = Path (Right sel : path) + +------------------------------------------------------------ + +instance Print STerm where + prt (SArg n c p) = prt c ++ "@" ++ prt n ++ prt p + prt (SCon c []) = prt c + prt (SCon c ts) = prt c ++ prtList ts + prt (SRec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ ";" | (l,t) <- rec ] ++ "}" + prt (STbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ ";" | (p,t) <- tbl ] ++ "}" + prt (SVariants ts) = "{| " ++ prtSep " | " ts ++ " |}" + prt (SConcat t1 t2) = prt t1 ++ "++" ++ prt t2 + prt (SToken t) = prt t + prt (SEmpty) = "[]" + prt (SWildcard) = "_" + +instance Print MCFCat where + prt (MCFCat cat params) + = prt cat ++ "{" ++ concat [ prt path ++ "=" ++ prt term ++ ";" | + (path, term) <- params ] ++ "}" + +instance Print CFName where + prt (CFName name profile) = prt name ++ prt profile + +instance Print CFCat where + prt (CFCat cat lbl) = prt cat ++ prt lbl + +instance Print Path where + prt (Path path) = concatMap prtEither (reverse path) + where prtEither (Left lbl) = "." ++ prt lbl + prtEither (Right patt) = "!" ++ prt patt diff --git a/src-3.0/GF/OldParsing/IncrementalChart.hs b/src-3.0/GF/OldParsing/IncrementalChart.hs new file mode 100644 index 000000000..132ed4dc4 --- /dev/null +++ b/src-3.0/GF/OldParsing/IncrementalChart.hs @@ -0,0 +1,50 @@ +---------------------------------------------------------------------- +-- | +-- Module : IncrementalChart +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:47 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Implementation of /incremental/ deductive parsing, +-- i.e. parsing one word at the time. +----------------------------------------------------------------------------- + + +module GF.OldParsing.IncrementalChart + (-- * Type definitions + IncrementalChart, + -- * Functions + buildChart, + chartList + ) where + +import Data.Array +import GF.Data.SortedList +import GF.Data.Assoc + +buildChart :: (Ord item, Ord key) => (item -> key) -> + (Int -> item -> SList item) -> + (Int -> SList item) -> + (Int, Int) -> IncrementalChart item key + +chartList :: (Ord item, Ord key) => (Int -> item -> edge) -> IncrementalChart item key -> [edge] + +type IncrementalChart item key = Array Int (Assoc key (SList item)) + +---------- + +buildChart keyof rules axioms bounds = finalChartArray + where buildState k = limit (rules k) $ axioms k + finalChartList = map buildState [fst bounds .. snd bounds] + finalChartArray = listArray bounds $ map stateAssoc finalChartList + stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ] + +chartList combine chart = [ combine k item | + (k, state) <- assocs chart, + item <- concatMap snd $ aAssocs state ] + + diff --git a/src-3.0/GF/OldParsing/MCFGrammar.hs b/src-3.0/GF/OldParsing/MCFGrammar.hs new file mode 100644 index 000000000..ff9d7de1b --- /dev/null +++ b/src-3.0/GF/OldParsing/MCFGrammar.hs @@ -0,0 +1,206 @@ +---------------------------------------------------------------------- +-- | +-- Module : MCFGrammar +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:48 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Definitions of multiple context-free grammars, +-- parser information and chart conversion +----------------------------------------------------------------------------- + +module GF.OldParsing.MCFGrammar + (-- * Type definitions + Grammar, + Rule(..), + Lin(..), + -- * Parser information + MCFParser, + MEdge, + edges2chart, + PInfo, + pInfo, + -- * Ranges + Range(..), + makeRange, + concatRange, + unifyRange, + unionRange, + failRange, + -- * Utilities + select, + updateIndex + ) where + +-- gf modules: +import GF.Data.SortedList +import GF.Data.Assoc +-- parser modules: +import GF.OldParsing.Utilities +import GF.Printing.PrintParser + + + +select :: [a] -> [(a, [a])] +select [] = [] +select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ] + +updateIndex :: Functor f => Int -> [a] -> (a -> f a) -> f [a] +updateIndex 0 (a:as) f = fmap (:as) $ f a +updateIndex n (a:as) f = fmap (a:) $ updateIndex (n-1) as f +updateIndex _ _ _ = error "ParserUtils.updateIndex: Index out of range" + + +------------------------------------------------------------ +-- grammar types + +type Grammar n c l t = [Rule n c l t] +data Rule n c l t = Rule c [c] [Lin c l t] n + deriving (Eq, Ord, Show) +data Lin c l t = Lin l [Symbol (c, l, Int) t] + deriving (Eq, Ord, Show) + +-- variants is simply several linearizations with the same label + + +------------------------------------------------------------ +-- parser information + +type PInfo n c l t = Grammar n c l t + +pInfo :: Grammar n c l t -> PInfo n c l t +pInfo = id + +type MCFParser n c l t = PInfo n c l t -> [c] -> Input t -> ParseChart n (MEdge c l) + +type MEdge c l = (c, [(l, Range)]) + +edges2chart :: (Ord n, Ord c, Ord l) => + [(n, MEdge c l, [MEdge c l])] -> ParseChart n (MEdge c l) +edges2chart edges = fmap groupPairs $ accumAssoc id $ + [ (medge, (name, medges)) | (name, medge, medges) <- edges ] + + +------------------------------------------------------------ +-- ranges as sets of int-pairs + +newtype Range = Rng (SList (Int, Int)) deriving (Eq, Ord, Show) + +makeRange :: SList (Int, Int) -> Range +makeRange rho = Rng rho + +concatRange :: Range -> Range -> Range +concatRange (Rng rho) (Rng rho') = Rng $ nubsort [ (i,k) | (i,j) <- rho, (j',k) <- rho', j==j' ] + +unifyRange :: Range -> Range -> Range +unifyRange (Rng rho) (Rng rho') = Rng $ rho <**> rho' + +unionRange :: Range -> Range -> Range +unionRange (Rng rho) (Rng rho') = Rng $ rho <++> rho' + +failRange :: Range +failRange = Rng [] + + +------------------------------------------------------------ +-- pretty-printing + +instance (Print n, Print c, Print l, Print t) => Print (Rule n c l t) where + prt (Rule cat args record name) + = prt name ++ ". " ++ prt cat ++ " -> " ++ prtSep " " args ++ "\n" ++ prt record + prtList = concatMap prt + +instance (Print c, Print l, Print t) => Print (Lin c l t) where + prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin) + where prArg (cat, lbl, arg) = prt cat ++ "@" ++ prt arg ++ "." ++ prt lbl + prtList = prtBeforeAfter "\t" "\n" + +instance Print Range where + prt (Rng rho) = "(" ++ prtSep "|" [ show i ++ "-" ++ show j | (i,j) <- rho ] ++ ")" + +{- +------------------------------------------------------------ +-- items & forests + +data Item n c l = Item n (MEdge c l) [[MEdge c l]] + deriving (Eq, Ord, Show) +type MEdge c l = (c, [Edge l]) + +items2forests :: (Ord n, Ord c, Ord l) => Edge ((c, l) -> Bool) -> [Item n c l] -> [ParseForest n] + +---------- + +items2forests (Edge i0 k0 startCat) items + = concatMap edge2forests $ filter checkEdge $ aElems chart + where edge2forests (cat, []) = [FMeta] + edge2forests edge = filter checkForest $ map item2forest (chart ? edge) + + item2forest (Item name _ children) = FNode name [ forests | edges <- children, + forests <- mapM edge2forests edges ] + + checkEdge (cat, [Edge i k lbl]) = i == i0 && k == k0 && startCat (cat, lbl) + checkEdge _ = False + + checkForest (FNode _ children) = not (null children) + + chart = accumAssoc id [ (edge, item) | item@(Item _ edge _) <- items ] +-} + + +------------------------------------------------------------ +-- grammar checking +{- +--checkGrammar :: (Ord c, Ord l, Print n, Print c, Print l, Print t) => Grammar n c l t -> [String] + +checkGrammar rules + = do rule@(Rule cat rhs record name) <- rules + if null record + then [ "empty linearization record in rule: " ++ prt rule ] + else [ "category does not exist: " ++ prt rcat ++ "\n" ++ + " - in rule: " ++ prt rule | + rcat <- rhs, rcat `notElem` lhsCats ] ++ + do Lin _ lin <- record + Cat (arg, albl) <- lin + if arg<0 || arg>=length rhs + then [ "argument index out of range: " ++ show arg ++ "/" ++ prt albl ++ "\n" ++ + " - in rule: " ++ prt rule ] + else [ "label does not exist: " ++ prt albl ++ "\n" ++ + " - from rule: " ++ prt rule ++ + " - in rule: " ++ prt arule | + arule@(Rule _ acat _ arecord) <- rules, + acat == rhs !! arg, + albl `notElem` [ lbl | Lin lbl _ <- arecord ] ] + where lhsCats = nubsort [ cat | Rule _ cat _ _ <- rules ] +-} + + + + + +{----- +------------------------------------------------------------ +-- simplifications + +splitMRule :: (Ord n, Ord c, Ord l, Ord t) => Grammar n c l t -> Rule n c l t -> [Rule n c l t] +splitMRule rules (Rule name cat args record) = nubsort [ (Rule name cat args splitrec) | + (cat', lbls) <- rhsCats, cat == cat', + let splitrec = [ lin | lin@(Lin lbl _) <- record, lbl `elem` lbls ] ] + where rhsCats = limit rhsC lhsCats + lhsCats = nubsort [ (cat, [lbl]) | Rule _ cat _ record <- rules, Lin lbl _ <- record ] + rhsC (cat, lbls) = nubsort [ (rcat, rlbls) | + Rule _ cat' rhs lins <- rules, cat == cat', + (arg, rcat) <- zip [0..] rhs, + let rlbls = nubsort [ rlbl | Lin lbl lin <- lins, lbl `elem` lbls, + Cat (arg', rlbl) <- lin, arg == arg' ], + not $ null rlbls + ] + + +----} + + + diff --git a/src-3.0/GF/OldParsing/ParseCF.hs b/src-3.0/GF/OldParsing/ParseCF.hs new file mode 100644 index 000000000..e1ef32aee --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseCF.hs @@ -0,0 +1,82 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseCF +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:49 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Chart parsing of grammars in CF format +----------------------------------------------------------------------------- + +module GF.OldParsing.ParseCF (parse, alternatives) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm + +import GF.Data.SortedList (nubsort) +import GF.Data.Assoc +import qualified GF.CF.CF as CF +import qualified GF.CF.CFIdent as CFI +import GF.OldParsing.Utilities +import GF.OldParsing.CFGrammar +import qualified GF.OldParsing.ParseCFG as P + +type Token = CFI.CFTok +type Name = CFI.CFFun +type Category = CFI.CFCat + +alternatives :: [(String, [String])] +alternatives = [ ("gb", ["G","GB","_gen","_genBU"]), + ("gt", ["GT","_genTD"]), + ("ibn", ["","I","B","IB","IBN","_inc","BU","_incBU"]), + ("ibb", ["BB","IBB","BU_BUF","_incBU_BUF"]), + ("ibt", ["BT","IBT","BU_TDF","_incBU_TDF"]), + ("iba", ["BA","IBA","BU_BTF","BU_TBF","_incBU_BTF","_incBU_TBF"]), + ("itn", ["T","IT","ITN","TD","_incTD"]), + ("itb", ["TB","ITB","TD_BUF","_incTD_BUF"]) + ] + +parse :: String -> CF.CF -> Category -> CF.CFParser +parse = buildParser . P.parse + +buildParser :: CFParser Name Category Token -> CF.CF -> Category -> CF.CFParser +buildParser parser cf start tokens = trace "ParseCF" $ + (parseResults, parseInformation) + where parseInformation = prtSep "\n" trees + parseResults = {-take maxTake-} [ (tree2cfTree t, []) | t <- trees ] + theInput = input tokens + edges = tracePrt "#edges" (prt.length) $ + parser pInf [start] theInput + chart = tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ + edges2chart theInput $ map (fmap addCategory) edges + forests = tracePrt "#forests" (prt.length) $ + chart2forests chart (const False) $ + uncurry Edge (inputBounds theInput) start + trees = tracePrt "#trees" (prt.length) $ + concatMap forest2trees forests + pInf = pInfo $ cf2grammar cf (nubsort tokens) + + +addCategory (Rule cat rhs name) = Rule cat rhs (name, cat) + +tree2cfTree (TNode (name, cat) trees) = CF.CFTree (name, (cat, map tree2cfTree trees)) + +cf2grammar :: CF.CF -> [Token] -> Grammar Name Category Token +cf2grammar cf tokens = [ Rule cat rhs name | + (name, (cat, rhs0)) <- cfRules, + rhs <- mapM item2symbol rhs0 ] + where cfRules = concatMap (CF.predefRules (CF.predefOfCF cf)) tokens ++ + CF.rulesOfCF cf + item2symbol (CF.CFNonterm cat) = [Cat cat] + item2symbol item = map Tok $ filter (CF.matchCFTerm item) tokens + +-- maxTake :: Int +-- maxTake = 500 +-- maxTake = maxBound + + diff --git a/src-3.0/GF/OldParsing/ParseCFG.hs b/src-3.0/GF/OldParsing/ParseCFG.hs new file mode 100644 index 000000000..03c1d7dcc --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseCFG.hs @@ -0,0 +1,43 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseCFG +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:49 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Main parsing module for context-free grammars +----------------------------------------------------------------------------- + + +module GF.OldParsing.ParseCFG (parse) where + +import Data.Char (toLower) +import GF.OldParsing.Utilities +import GF.OldParsing.CFGrammar +import qualified GF.OldParsing.ParseCFG.General as PGen +import qualified GF.OldParsing.ParseCFG.Incremental as PInc + + +parse :: (Ord n, Ord c, Ord t, Show t) => + String -> CFParser n c t +parse = decodeParser . map toLower + +decodeParser ['g',s] = PGen.parse (decodeStrategy s) +decodeParser ['i',s,f] = PInc.parse (decodeStrategy s, decodeFilter f) +decodeParser _ = decodeParser "ibn" + +decodeStrategy 'b' = (True, False) +decodeStrategy 't' = (False, True) + +decodeFilter 'a' = (True, True) +decodeFilter 'b' = (True, False) +decodeFilter 't' = (False, True) +decodeFilter 'n' = (False, False) + + + + diff --git a/src-3.0/GF/OldParsing/ParseCFG/General.hs b/src-3.0/GF/OldParsing/ParseCFG/General.hs new file mode 100644 index 000000000..438c89f1a --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseCFG/General.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseCFG.General +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:00 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Several implementations of CFG chart parsing +----------------------------------------------------------------------------- + +module GF.OldParsing.ParseCFG.General + (parse, Strategy) where + +import GF.System.Tracing + +import GF.OldParsing.Utilities +import GF.OldParsing.CFGrammar +import GF.OldParsing.GeneralChart +import GF.Data.Assoc + +parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser n c t +parse strategy grammar start = extract . process strategy grammar start + +type Strategy = (Bool, Bool) -- (isBottomup, isTopdown) + +extract :: [Item n (Symbol c t)] -> [Edge (Rule n c t)] +extract edges = + edges' + where edges' = [ Edge j k (Rule cat (reverse found) name) | + Edge j k (Cat cat, found, [], Just name) <- edges ] + +process :: (Ord n, Ord c, Ord t) => Strategy -> PInfo n c t -> + [c] -> Input t -> [Item n (Symbol c t)] +process (isBottomup, isTopdown) grammar start + = trace2 "CFParserGeneral" ((if isBottomup then " BU" else "") ++ + (if isTopdown then " TD" else "")) $ + buildChart keyof [predict, combine] . axioms + where axioms input = initial ++ scan input + + scan input = map (fmap mkEdge) (inputEdges input) + mkEdge tok = (Tok tok, [], [], Nothing) + + -- the combine rule + combine chart (Edge j k (next, _, [], _)) + = [ edge `forwardTo` k | edge <- chartLookup chart (Active next j) ] + combine chart edge@(Edge _ j (_, _, next:_, _)) + = [ edge `forwardTo` k | Edge _ k _ <- chartLookup chart (Passive next j) ] + + -- initial predictions + initial = [ loopingEdge 0 rule | cat <- start, rule <- tdRuleLookup ? cat ] + + -- predictions + predict chart (Edge j k (next, _, [], _)) | isBottomup + = [ loopingEdge j rule `forwardTo` k | rule <- bottomupRules grammar ? next ] + -- - - - - - - - - - ^^^^^^^^^^^^^ Kilbury prediction: move dot forward + predict chart (Edge _ k (_, _, Cat cat:_, _)) + = [ loopingEdge k rule | rule <- tdRuleLookup ? cat ] + predict _ _ = [] + + tdRuleLookup | isTopdown = topdownRules grammar + | isBottomup = emptyLeftcornerRules grammar + +-- internal representation of parse items + +type Item n s = Edge (s, [s], [s], Maybe n) +type IChart n s = Chart (Item n s) (IKey s) +data IKey s = Active s Int + | Passive s Int + deriving (Eq, Ord, Show) + +keyof (Edge _ j (_, _, next:_, _)) = Active next j +keyof (Edge j _ (cat, _, [], _)) = Passive cat j + +forwardTo (Edge i j (cat, found, next:tofind, name)) k = Edge i k (cat, next:found, tofind, name) + +loopingEdge k (Rule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name) + + + diff --git a/src-3.0/GF/OldParsing/ParseCFG/Incremental.hs b/src-3.0/GF/OldParsing/ParseCFG/Incremental.hs new file mode 100644 index 000000000..f1bcde404 --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseCFG/Incremental.hs @@ -0,0 +1,142 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseCFG.Incremental +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:01 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Incremental chart parsing for context-free grammars +----------------------------------------------------------------------------- + + + +module GF.OldParsing.ParseCFG.Incremental + (parse, Strategy) where + +import GF.System.Tracing +import GF.Printing.PrintParser + +-- haskell modules: +import Data.Array +-- gf modules: +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Data.Operations +-- parser modules: +import GF.OldParsing.Utilities +import GF.OldParsing.CFGrammar +import GF.OldParsing.IncrementalChart + + +type Strategy = ((Bool, Bool), (Bool, Bool)) -- (predict:(BU, TD), filter:(BU, TD)) + +parse :: (Ord n, Ord c, Ord t, Show t) => + Strategy -> CFParser n c t +parse ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input = + trace2 "CFParserIncremental" + ((if isPredictBU then "BU-predict " else "") ++ + (if isPredictTD then "TD-predict " else "") ++ + (if isFilterBU then "BU-filter " else "") ++ + (if isFilterTD then "TD-filter " else "")) $ + finalEdges + where finalEdges = [ Edge j k (Rule cat (reverse found) name) | + (k, state) <- + tracePrt "#passiveChart" + (prt . map (length . (?Passive) . snd)) $ + tracePrt "#activeChart" + (prt . map (length . concatMap snd . aAssocs . snd)) $ + assocs finalChart, + Item j (Rule cat _Nil name) found <- state ? Passive ] + + finalChart = buildChart keyof rules axioms $ inputBounds input + + axioms 0 = --tracePrt ("axioms 0") (prtSep "\n") $ + union $ map (tdInfer 0) start + axioms k = --tracePrt ("axioms "++show k) (prtSep "\n") $ + union [ buInfer j k (Tok token) | + (token, js) <- aAssocs (inputTo input ! k), j <- js ] + + rules k (Item j (Rule cat [] _) _) + = buInfer j k (Cat cat) + rules k (Item j rule@(Rule _ (Cat next:_) _) found) + = tdInfer k next <++> + -- hack for empty rules: + [ Item j (forward rule) (Cat next:found) | + emptyCategories grammar ?= next ] + rules _ _ = [] + + buInfer j k next = --tracePrt ("buInfer "++show(j,k)++" "++prt next) (prtSep "\n") $ + buPredict j k next <++> buCombine j k next + tdInfer k next = tdPredict k next + + -- the combine rule + buCombine j k next + | j == k = [] -- hack for empty rules + | otherwise = [ Item i (forward rule) (next:found) | + Item i rule found <- (finalChart ! j) ? Active next ] + + -- kilbury bottom-up prediction + buPredict j k next + = [ Item j rule [next] | isPredictBU, + rule <- map forward $ --tracePrt ("buRules "++prt next) (prtSep "\n") $ + bottomupRules grammar ? next, + buFilter rule k, + tdFilter rule j k ] + + -- top-down prediction + tdPredict k cat + = [ Item k rule [] | isPredictTD || isFilterTD, + rule <- topdownRules grammar ? cat, + buFilter rule k ] <++> + -- hack for empty rules: + [ Item k rule [] | isPredictBU, + rule <- emptyLeftcornerRules grammar ? cat ] + + -- bottom up filtering: input symbol k can begin the given symbol list (first set) + -- leftcornerTokens DOESN'T WORK WITH EMPTY RULES!!! + buFilter (Rule _ (Cat cat:_) _) k | isFilterBU + = k < snd (inputBounds input) && + hasCommonElements (leftcornerTokens grammar ? cat) + (aElems (inputFrom input ! k)) + buFilter _ _ = True + + -- top down filtering: 'cat' is reachable by an active edge ending in node j < k + tdFilter (Rule cat _ _) j k | isFilterTD && j < k + = (tdFilters ! j) ?= cat + tdFilter _ _ _ = True + + tdFilters = listArray (inputBounds input) $ + map (listSet . limit leftCats . activeCats) [0..] + activeCats j = [ next | Active (Cat next) <- aElems (finalChart ! j) ] + leftCats cat = [ left | Rule _cat (Cat left:_) _ <- topdownRules grammar ? cat ] + + +-- type declarations, items & keys +data Item n c t = Item Int (Rule n c t) [Symbol c t] + deriving (Eq, Ord, Show) + +data IKey c t = Active (Symbol c t) | Passive + deriving (Eq, Ord, Show) + +keyof :: Item n c t -> IKey c t +keyof (Item _ (Rule _ (next:_) _) _) = Active next +keyof (Item _ (Rule _ [] _) _) = Passive + +forward :: Rule n c t -> Rule n c t +forward (Rule cat (_:rest) name) = Rule cat rest name + + +instance (Print n, Print c, Print t) => Print (Item n c t) where + prt (Item k (Rule cat rhs name) syms) + = "<" ++show k++ ": "++prt name++". "++ + prt cat++" -> "++prt rhs++" / "++prt syms++">" + +instance (Print c, Print t) => Print (IKey c t) where + prt (Active sym) = "?" ++ prt sym + prt (Passive) = "!" + + diff --git a/src-3.0/GF/OldParsing/ParseGFC.hs b/src-3.0/GF/OldParsing/ParseGFC.hs new file mode 100644 index 000000000..fbc6cff5a --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseGFC.hs @@ -0,0 +1,177 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseGFC +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:50 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- The main parsing module, parsing GFC grammars +-- by translating to simpler formats, such as PMCFG and CFG +---------------------------------------------------------------------- + +module GF.OldParsing.ParseGFC (newParser) where + +import GF.System.Tracing +import GF.Printing.PrintParser +import qualified GF.Grammar.PrGrammar as PrGrammar + +-- Haskell modules +import Control.Monad +-- import Ratio ((%)) +-- GF modules +import qualified GF.Grammar.Grammar as GF +import GF.Grammar.Values +import qualified GF.Grammar.Macros as Macros +import qualified GF.Infra.Modules as Mods +import qualified GF.Canon.AbsGFC as AbsGFC +import qualified GF.Infra.Ident as Ident +import qualified GF.Compile.ShellState as SS +import GF.Data.Operations +import GF.Data.SortedList +-- Conversion and parser modules +import GF.Data.Assoc +import GF.OldParsing.Utilities +-- import ConvertGrammar +import GF.OldParsing.GrammarTypes +import qualified GF.OldParsing.MCFGrammar as M +import qualified GF.OldParsing.CFGrammar as C +import qualified GF.OldParsing.ParseMCFG as PM +import qualified GF.OldParsing.ParseCFG as PC +--import MCFRange + +newParser :: String -> SS.StateGrammar -> GF.Cat -> String -> Err [GF.Term] + +-- parsing via MCFG +newParser (m:strategy) gr (_, startCat) inString + | m=='m' || m=='M' = trace2 "Parser" "MCFG" $ Ok terms + where terms = map (ptree2term abstract) trees + trees = --tracePrt "trees" (prtBefore "\n") $ + tracePrt "#trees" (prt . length) $ + concatMap forest2trees forests + forests = --tracePrt "forests" (prtBefore "\n") $ + tracePrt "#forests" (prt . length) $ + concatMap (chart2forests chart isMeta) finalEdges + isMeta = null . snd + finalEdges = tracePrt "finalEdges" (prtBefore "\n") $ + filter isFinalEdge $ aElems chart +-- nubsort [ (cat, [(lbl, E.makeRange [(i,j)])]) | +-- let (i, j) = inputBounds inTokens, +-- E.Rule cat _ [E.Lin lbl _] _ <- pInf, +-- isStartCat cat ] + isFinalEdge (cat, rows) + = isStartCat cat && + inputBounds inTokens `elem` concat [ rho | (_, M.Rng rho) <- rows ] + chart = --tracePrt "chart" (prtBefore "\n" . aAssocs) $ + tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ + PM.parse strategy pInf starters inTokens + inTokens = input $ map AbsGFC.KS $ words inString + pInf = -- tracePrt "avg rec" (\gr -> show (sum [ length rec | E.Rule _ _ rec _ <- gr ] % length gr)) $ + mcfPInfo $ SS.statePInfoOld gr + starters = tracePrt "startCats" prt $ + filter isStartCat $ nubsort [ cat | M.Rule cat _ _ _ <- pInf ] + isStartCat (MCFCat cat _) = cat == startCat + abstract = tracePrt "abstract module" PrGrammar.prt $ + SS.absId gr + +-- parsing via CFG +newParser (c:strategy) gr (_, startCat) inString + | c=='c' || c=='C' = trace2 "Parser" "CFG" $ Ok terms + where terms = -- tracePrt "terms" (unlines . map PrGrammar.prt) $ + map (ptree2term abstract) trees + trees = tracePrt "#trees" (prt . length) $ + --tracePrt "trees" (prtSep "\n") $ + concatMap forest2trees forests + forests = tracePrt "$cfForests" (prt) $ -- . length) $ + tracePrt "forests" (unlines . map prt) $ + concatMap convertFromCFForest cfForests + cfForests= tracePrt "cfForests" (unlines . map prt) $ + concatMap (chart2forests chart (const False)) finalEdges + finalEdges = tracePrt "finalChartEdges" prt $ + map (uncurry Edge (inputBounds inTokens)) starters + chart = --tracePrt "finalChartEdges" (prt . (? finalEdge)) $ + tracePrt "#chart" (prt . map (length.snd) . aAssocs) $ + C.edges2chart inTokens edges + edges = --tracePrt "finalEdges" + --(prt . filter (\(Edge i j _) -> (i,j)==inputBounds inTokens)) $ + tracePrt "#edges" (prt . length) $ + PC.parse strategy pInf starters inTokens + inTokens = input $ map AbsGFC.KS $ words inString + pInf = cfPInfo $ SS.statePInfoOld gr + starters = tracePrt "startCats" prt $ + filter isStartCat $ map fst $ aAssocs $ C.topdownRules pInf + isStartCat (CFCat (MCFCat cat _) _) = cat == startCat + abstract = tracePrt "abstract module" PrGrammar.prt $ + SS.absId gr + --ifNull (Ident.identC "ABS") last $ + --[i | (i, Mods.ModMod m) <- Mods.modules (SS.grammar gr), Mods.isModAbs m] + +newParser "" gr start inString = newParser "c" gr start inString + +newParser opt gr (_,cat) _ = + Bad ("new-parser '" ++ opt ++ "' not defined yet") + +ptree2term :: Ident.Ident -> ParseTree Name -> GF.Term +ptree2term a (TNode f ts) = Macros.mkApp (Macros.qq (a,f)) (map (ptree2term a) ts) +ptree2term a (TMeta) = GF.Meta (GF.MetaSymb 0) + +---------------------------------------------------------------------- +-- conversion and unification of forests + +convertFromCFForest :: ParseForest CFName -> [ParseForest Name] +convertFromCFForest (FNode (CFName name profile) children) + | isCoercion name = concat chForests + | otherwise = [ FNode name chForests | not (null chForests) ] + where chForests = concat [ mapM (checkProfile forests) profile | + forests0 <- children, + forests <- mapM convertFromCFForest forests0 ] + checkProfile forests = unifyManyForests . map (forests !!) + -- foldM unifyForests FMeta . map (forests !!) + +isCoercion Ident.IW = True +isCoercion _ = False + +unifyManyForests :: Eq n => [ParseForest n] -> [ParseForest n] +unifyManyForests [] = [FMeta] +unifyManyForests [f] = [f] +unifyManyForests (f:g:fs) = do h <- unifyForests f g + unifyManyForests (h:fs) + +unifyForests :: Eq n => ParseForest n -> ParseForest n -> [ParseForest n] +unifyForests FMeta forest = [forest] +unifyForests forest FMeta = [forest] +unifyForests (FNode name1 children1) (FNode name2 children2) + = [ FNode name1 children | name1 == name2, not (null children) ] + where children = [ forests | forests1 <- children1, forests2 <- children2, + forests <- zipWithM unifyForests forests1 forests2 ] + + + +{- +---------------------------------------------------------------------- +-- conversion and unification for parse trees instead of forests + +convertFromCFTree :: ParseTree CFName -> [ParseTree Name] +convertFromCFTree (TNode (CFName name profile) children0) + = [ TNode name children | + children1 <- mapM convertFromCFTree children0, + children <- mapM (checkProfile children1) profile ] + where checkProfile trees = unifyManyTrees . map (trees !!) + +unifyManyTrees :: Eq n => [ParseTree n] -> [ParseTree n] +unifyManyTrees [] = [TMeta] +unifyManyTrees [f] = [f] +unifyManyTrees (f:g:fs) = do h <- unifyTrees f g + unifyManyTrees (h:fs) + +unifyTrees TMeta tree = [tree] +unifyTrees tree TMeta = [tree] +unifyTrees (TNode name1 children1) (TNode name2 children2) + = [ TNode name1 children | name1 == name2, + children <- zipWithM unifyTrees children1 children2 ] + +-} + diff --git a/src-3.0/GF/OldParsing/ParseMCFG.hs b/src-3.0/GF/OldParsing/ParseMCFG.hs new file mode 100644 index 000000000..c845a76b3 --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseMCFG.hs @@ -0,0 +1,37 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseMCFG +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:52 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Main module for MCFG parsing +----------------------------------------------------------------------------- + + +module GF.OldParsing.ParseMCFG (parse) where + +import Data.Char (toLower) +import GF.OldParsing.Utilities +import GF.OldParsing.MCFGrammar +import qualified GF.OldParsing.ParseMCFG.Basic as PBas +import GF.Printing.PrintParser +---- import qualified MCFParserBasic2 as PBas2 -- file not found AR + + +parse :: (Ord n, Ord c, Ord l, Ord t, + Print n, Print c, Print l, Print t) => + String -> MCFParser n c l t +parse str = decodeParser (map toLower str) + +decodeParser "b" = PBas.parse +---- decodeParser "c" = PBas2.parse +decodeParser _ = decodeParser "b" + + + + diff --git a/src-3.0/GF/OldParsing/ParseMCFG/Basic.hs b/src-3.0/GF/OldParsing/ParseMCFG/Basic.hs new file mode 100644 index 000000000..baf7e4b2a --- /dev/null +++ b/src-3.0/GF/OldParsing/ParseMCFG/Basic.hs @@ -0,0 +1,156 @@ +---------------------------------------------------------------------- +-- | +-- Module : ParseMCFG.Basic +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:03 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Simplest possible implementation of MCFG chart parsing +----------------------------------------------------------------------------- + +module GF.OldParsing.ParseMCFG.Basic + (parse) where + +import GF.System.Tracing + +import Data.Ix +import GF.OldParsing.Utilities +import GF.OldParsing.MCFGrammar +import GF.OldParsing.GeneralChart +import GF.Data.Assoc +import GF.Data.SortedList +import GF.Printing.PrintParser + + +parse :: (Ord n, Ord c, Ord l, Ord t, + Print n, Print c, Print l, Print t) => + MCFParser n c l t +parse grammar start = edges2chart . extract . process grammar + + +extract :: [Item n c l t] -> [(n, MEdge c l, [MEdge c l])] +extract items = tracePrt "#passives" (prt.length) $ + --trace2 "passives" (prtAfter "\n" [ i | i@(PItem _) <- items ]) $ + [ item | PItem item <- items ] + + +process :: (Ord n, Ord c, Ord l, Ord t, + Print n, Print c, Print l, Print t) => + Grammar n c l t -> Input t -> [Item n c l t] +process grammar input = buildChart keyof rules axioms + where axioms = initial + rules = [combine, scan, predict] + + -- axioms + initial = traceItems "axiom" [] $ + [ nextLin name tofind (addNull cat) (map addNull args) | + Rule cat args tofind name <- grammar ] + + addNull a = (a, []) + + -- predict + predict chart i1@(Item name tofind rho (Lin lbl []) (cat, found0) children) + = traceItems "predict" [i1] + [ nextLin name tofind (cat, found) children | + let found = insertRow lbl rho found0 ] + predict _ _ = [] + + -- combine + combine chart active@(Item _ _ _ (Lin _ (Cat(cat,_,_):_)) _ _) + = do passive <- chartLookup chart (Passive cat) + combineItems active passive + combine chart passive@(PItem (_, (cat, _), _)) + = do active <- chartLookup chart (Active cat) + combineItems active passive + combine _ _ = [] + + combineItems i1@(Item name tofind rho0 (Lin lbl (Cat(_,lbl',nr):rest)) found children0) + i2@(PItem (_, found', _)) + = traceItems "combine" [i1,i2] + [ Item name tofind rho (Lin lbl rest) found children | + rho1 <- lookupLbl lbl' found', + let rho = concatRange rho0 rho1, + children <- updateChild nr children0 (snd found') ] + + -- scan + scan chart i1@(Item name tofind rho0 (Lin lbl (Tok tok:rest)) found children) + = traceItems "scan" [i1] + [ Item name tofind rho (Lin lbl rest) found children | + let rho = concatRange rho0 (rangeOfToken tok) ] + scan _ _ = [] + + -- utilities + rangeOfToken tok = makeRange $ inputToken input ? tok + + zeroRange = makeRange $ map (\i -> (i,i)) $ range $ inputBounds input + + nextLin name [] found children = PItem (name, found, children) + nextLin name (lin : tofind) found children + = Item name tofind zeroRange lin found children + +lookupLbl a = map snd . filter (\b -> a == fst b) . snd +updateChild nr children found = updateIndex nr children $ + \child -> if null (snd child) + then [ (fst child, found) ] + else [ child | snd child == found ] + +insertRow lbl rho [] = [(lbl, rho)] +insertRow lbl rho rows'@(row@(lbl', rho') : rows) + = case compare lbl lbl' of + LT -> row : insertRow lbl rho rows + GT -> (lbl, rho) : rows' + EQ -> (lbl, unionRange rho rho') : rows + + +-- internal representation of parse items + +data Item n c l t + = Item n [Lin c l t] -- tofind + Range (Lin c l t) -- current row + (MEdge c l) -- found rows + [MEdge c l] -- found children + | PItem (n, MEdge c l, [MEdge c l]) + deriving (Eq, Ord, Show) + +data IKey c = Passive c | Active c | AnyItem + deriving (Eq, Ord, Show) + +keyof (PItem (_, (cat, _), _)) = Passive cat +keyof (Item _ _ _ (Lin _ (Cat(cat,_,_):_)) _ _) = Active cat +keyof _ = AnyItem + + +-- tracing + +--type TraceItem = Item String String Char String +traceItems :: (Print n, Print l, Print c, Print t) => + String -> [Item n c l t] -> [Item n c l t] -> [Item n c l t] +traceItems rule trigs items + | null items || True = items + | otherwise = trace ("\n" ++ rule ++ ":" ++ + unlines [ "\t" ++ prt i | i <- trigs ] ++ "=>" ++ + unlines [ "\t" ++ prt i | i <- items ]) items + +-- pretty-printing + +instance (Print n, Print c, Print l, Print t) => Print (Item n c l t) where + prt (Item name tofind rho lin (cat, found) children) + = prt name ++ ". " ++ prt cat ++ prtRhs (map fst children) ++ + " { " ++ prt rho ++ prt lin ++ " ; " ++ + concat [ prt lbl ++ "=" ++ prt ln ++ " " | + Lin lbl ln <- tofind ] ++ "; " ++ + concat [ prt lbl ++ "=" ++ prt rho ++ " " | + (lbl, rho) <- found ] ++ "} " ++ + concat [ "[ " ++ concat [ prt lbl ++ "=" ++ prt rho ++ " " | + (lbl,rho) <- child ] ++ "] " | + child <- map snd children ] + prt (PItem (name, edge, edges)) + = prt name ++ ". " ++ prt edge ++ prtRhs edges + +prtRhs [] = "" +prtRhs rhs = " -> " ++ prtSep " " rhs + diff --git a/src-3.0/GF/OldParsing/SimpleGFC.hs b/src-3.0/GF/OldParsing/SimpleGFC.hs new file mode 100644 index 000000000..59f379bb4 --- /dev/null +++ b/src-3.0/GF/OldParsing/SimpleGFC.hs @@ -0,0 +1,161 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:52 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Simplistic GFC format +----------------------------------------------------------------------------- + +module GF.OldParsing.SimpleGFC where + +import qualified GF.Canon.AbsGFC as AbsGFC +import qualified GF.Infra.Ident as Ident + +import GF.Printing.PrintParser +import GF.Printing.PrintSimplifiedTerm + +import GF.Data.Operations (ifNull) + +---------------------------------------------------------------------- + +type Name = Ident.Ident +type Cat = Ident.Ident +type Constr = AbsGFC.CIdent +type Var = Ident.Ident +type Token = AbsGFC.Tokn +type Label = AbsGFC.Label + +constr2name :: Constr -> Name +constr2name (AbsGFC.CIQ _ name) = name + +---------------------------------------------------------------------- + +type Grammar = [Rule] +data Rule = Rule Name Typing (Maybe (Term, CType)) + deriving (Eq, Ord, Show) + +type Typing = (Type, [Decl]) + +data Decl = Var ::: Type + deriving (Eq, Ord, Show) +data Type = Cat :@ [Atom] + deriving (Eq, Ord, Show) +data Atom = ACon Constr + | AVar Var + deriving (Eq, Ord, Show) + +data CType = RecT [(Label, CType)] + | TblT CType CType + | ConT Constr [Term] + | StrT + deriving (Eq, Ord, Show) + + +data Term = Arg Int Cat Path -- ^ argument variable, the 'Path' is a path + -- pointing into the term + | Constr :^ [Term] -- ^ constructor + | Rec [(Label, Term)] -- ^ record + | Term :. Label -- ^ record projection + | Tbl [(Term, Term)] -- ^ table of patterns\/terms + | Term :! Term -- ^ table selection + | Variants [Term] -- ^ variants + | Term :++ Term -- ^ concatenation + | Token Token -- ^ single token + | Empty -- ^ empty string + | Wildcard -- ^ wildcard pattern variable + | Var Var -- ^ bound pattern variable + + -- Res CIdent -- resource identifier + -- Int Integer -- integer + deriving (Eq, Ord, Show) + + +---------------------------------------------------------------------- + +(+.) :: Term -> Label -> Term +Variants terms +. lbl = Variants $ map (+. lbl) terms +Rec record +. lbl = maybe err id $ lookup lbl record + where err = error $ "(+.), label not in record: " ++ show (Rec record) ++ " +. " ++ show lbl +Arg arg cat path +. lbl = Arg arg cat (path ++. lbl) +term +. lbl = term :. lbl + +(+!) :: Term -> Term -> Term +Variants terms +! pat = Variants $ map (+! pat) terms +term +! Variants pats = Variants $ map (term +!) pats +Tbl table +! pat = maybe err id $ lookup pat table + where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat +Arg arg cat path +! pat = Arg arg cat (path ++! pat) +term +! pat = term :! pat + +(?++) :: Term -> Term -> Term +Variants terms ?++ term = Variants $ map (?++ term) terms +term ?++ Variants terms = Variants $ map (term ?++) terms +Empty ?++ term = term +term ?++ Empty = term +term1 ?++ term2 = term1 :++ term2 + +---------------------------------------------------------------------- + +newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show) + +emptyPath :: Path +emptyPath = Path [] + +(++.) :: Path -> Label -> Path +Path path ++. lbl = Path (Left lbl : path) + +(++!) :: Path -> Term -> Path +Path path ++! sel = Path (Right sel : path) + +---------------------------------------------------------------------- + +instance Print Rule where + prt (Rule name (typ, args) term) + = prt name ++ " : " ++ + prtAfter " " args ++ + (if null args then "" else "-> ") ++ + prt typ ++ + maybe "" (\(t,c) -> " := " ++ prt t ++ " : " ++ prt c) term ++ + "\n" + prtList = concatMap prt + +instance Print Decl where + prt (var ::: typ) = "(" ++ prt var ++ ":" ++ prt typ ++ ")" + +instance Print Type where + prt (cat :@ ats) = prt cat ++ prtList ats + +instance Print Atom where + prt (ACon con) = prt con + prt (AVar var) = "?" ++ prt var + +instance Print CType where + prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}" + prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")" + prt (ConT t ts) = prt t ++ "(|" ++ prtSep "|" ts ++ "|)" + prt (StrT) = "Str" + +instance Print Term where + prt (Arg n c p) = prt c ++ "@" ++ prt n ++ prt p + prt (c :^ []) = prt c + prt (c :^ ts) = prt c ++ prtList ts + prt (Rec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}" + prt (Tbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "}" + prt (Variants ts) = "{| " ++ prtSep " | " ts ++ " |}" + prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2 + prt (Token t) = prt t + prt (Empty) = "[]" + prt (Wildcard) = "_" + prt (term :. lbl) = prt term ++ "." ++ prt lbl + prt (term :! sel) = prt term ++ " ! " ++ prt sel + prt (Var var) = "?" ++ prt var + +instance Print Path where + prt (Path path) = concatMap prtEither (reverse path) + where prtEither (Left lbl) = "." ++ prt lbl + prtEither (Right patt) = "!" ++ prt patt diff --git a/src-3.0/GF/OldParsing/Utilities.hs b/src-3.0/GF/OldParsing/Utilities.hs new file mode 100644 index 000000000..6bacfe1fe --- /dev/null +++ b/src-3.0/GF/OldParsing/Utilities.hs @@ -0,0 +1,188 @@ +---------------------------------------------------------------------- +-- | +-- Module : Parsing.Utilities +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:22:54 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Basic type declarations and functions to be used when parsing +----------------------------------------------------------------------------- + + +module GF.OldParsing.Utilities + ( -- * Symbols + Symbol(..), symbol, mapSymbol, + -- * Edges + Edge(..), + -- * Parser input + Input(..), makeInput, input, inputMany, + -- * charts, parse forests & trees + ParseChart, ParseForest(..), ParseTree(..), + chart2forests, forest2trees + ) where + +-- haskell modules: +import Control.Monad +import Data.Array +-- gf modules: +import GF.Data.SortedList +import GF.Data.Assoc +-- parsing modules: +import GF.Printing.PrintParser + +------------------------------------------------------------ +-- symbols + +data Symbol c t = Cat c | Tok t + deriving (Eq, Ord, Show) + +symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a +mapSymbol :: (c -> d) -> (t -> u) -> Symbol c t -> Symbol d u + +---------- + +symbol fc ft (Cat cat) = fc cat +symbol fc ft (Tok tok) = ft tok + +mapSymbol fc ft = symbol (Cat . fc) (Tok . ft) + + +------------------------------------------------------------ +-- edges + +data Edge s = Edge Int Int s + deriving (Eq, Ord, Show) + +instance Functor Edge where + fmap f (Edge i j s) = Edge i j (f s) + + +------------------------------------------------------------ +-- parser input + +data Input t = MkInput { inputEdges :: [Edge t], + inputBounds :: (Int, Int), + inputFrom :: Array Int (Assoc t [Int]), + inputTo :: Array Int (Assoc t [Int]), + inputToken :: Assoc t [(Int, Int)] + } + +makeInput :: Ord t => [Edge t] -> Input t +input :: Ord t => [t] -> Input t +inputMany :: Ord t => [[t]] -> Input t + +---------- + +makeInput inEdges | null inEdges = input [] + | otherwise = MkInput inEdges inBounds inFrom inTo inToken + where inBounds = foldr1 minmax [ (i, j) | Edge i j _ <- inEdges ] + where minmax (a, b) (a', b') = (min a a', max b b') + inFrom = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds $ + [ (i, [(tok, j)]) | Edge i j tok <- inEdges ] + inTo = fmap (accumAssoc id) $ accumArray (<++>) [] inBounds + [ (j, [(tok, i)]) | Edge i j tok <- inEdges ] + inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] + +input toks = MkInput inEdges inBounds inFrom inTo inToken + where inEdges = zipWith3 Edge [0..] [1..] toks + inBounds = (0, length toks) + inFrom = listArray inBounds $ + [ listAssoc [(tok, [j])] | (tok, j) <- zip toks [1..] ] ++ [ listAssoc [] ] + inTo = listArray inBounds $ + [ listAssoc [] ] ++ [ listAssoc [(tok, [i])] | (tok, i) <- zip toks [0..] ] + inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] + +inputMany toks = MkInput inEdges inBounds inFrom inTo inToken + where inEdges = [ Edge i j t | (i, j, ts) <- zip3 [0..] [1..] toks, t <- ts ] + inBounds = (0, length toks) + inFrom = listArray inBounds $ + [ listAssoc [ (t, [j]) | t <- nubsort ts ] | (ts, j) <- zip toks [1..] ] + ++ [ listAssoc [] ] + inTo = listArray inBounds $ + [ listAssoc [] ] ++ + [ listAssoc [ (t, [i]) | t <- nubsort ts ] | (ts, i) <- zip toks [0..] ] + inToken = accumAssoc id [ (tok, (i, j)) | Edge i j tok <- inEdges ] + + +------------------------------------------------------------ +-- charts, parse forests & trees + +type ParseChart n e = Assoc e [(n, [[e]])] + +data ParseForest n = FNode n [[ParseForest n]] | FMeta + deriving (Eq, Ord, Show) + +data ParseTree n = TNode n [ParseTree n] | TMeta + deriving (Eq, Ord, Show) + +chart2forests :: Ord e => ParseChart n e -> (e -> Bool) -> e -> [ParseForest n] + +--filterCoercions :: (n -> Bool) -> ParseForest n -> [ParseForest n] + +forest2trees :: ParseForest n -> [ParseTree n] + +instance Functor ParseTree where + fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees + fmap f (TMeta) = TMeta + +instance Functor ParseForest where + fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests + fmap f (FMeta) = FMeta + +---------- + +chart2forests chart isMeta = edge2forests + where item2forest (name, children) = FNode name $ + do edges <- children + mapM edge2forests edges + edge2forests edge + | isMeta edge = [FMeta] + | otherwise = filter checkForest $ map item2forest $ chart ? edge + checkForest (FNode _ children) = not (null children) + +-- filterCoercions _ (FMeta) = [FMeta] +-- filterCoercions isCoercion (FNode s forests) +-- | isCoercion s = do [forest] <- forests ; filterCoercions isCoercion forest +-- | otherwise = FNode s $ do children <- forests ; mapM (filterCoercions isCoercion) + +forest2trees (FNode s forests) = map (TNode s) $ forests >>= mapM forest2trees +forest2trees (FMeta) = [TMeta] + + + +------------------------------------------------------------ +-- pretty-printing + +instance (Print c, Print t) => Print (Symbol c t) where + prt = symbol prt (simpleShow.prt) + prtList = prtSep " " + +simpleShow :: String -> String +simpleShow s = "\"" ++ concatMap mkEsc s ++ "\"" + where + mkEsc :: Char -> String + mkEsc c = case c of + _ | elem c "\\\"" -> '\\' : [c] + '\n' -> "\\n" + '\t' -> "\\t" + _ -> [c] + +instance (Print s) => Print (Edge s) where + prt (Edge i j s) = "[" ++ show i ++ "-" ++ show j ++ ": " ++ prt s ++ "]" + prtList = prtSep "" + +instance (Print s) => Print (ParseTree s) where + prt (TNode s trees) = prt s ++ "^{" ++ prtSep " " trees ++ "}" + prt (TMeta) = "?" + prtList = prtAfter "\n" + +instance (Print s) => Print (ParseForest s) where + prt (FNode s forests) = prt s ++ "^{" ++ prtSep " | " (map (prtSep " ") forests) ++ "}" + prt (FMeta) = "?" + prtList = prtAfter "\n" + + diff --git a/src-3.0/GF/Parsing/CF.hs b/src-3.0/GF/Parsing/CF.hs new file mode 100644 index 000000000..1a65f6caf --- /dev/null +++ b/src-3.0/GF/Parsing/CF.hs @@ -0,0 +1,66 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:04 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- Chart parsing of grammars in CF format +----------------------------------------------------------------------------- + +module GF.Parsing.CF (parse) where + +import GF.Data.Operations (errVal) + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Data.SortedList (nubsort) +import GF.Data.Assoc +import qualified GF.CF.CF as CF +import qualified GF.CF.CFIdent as CFI +import GF.Formalism.Utilities +import GF.Formalism.CFG +import qualified GF.Parsing.CFG as P + +type Token = CFI.CFTok +type Name = CFI.CFFun +type Category = CFI.CFCat + +parse :: String -> CF.CF -> Category -> CF.CFParser +parse = buildParser . errVal (errVal undefined (P.parseCF "")) . P.parseCF + +buildParser :: P.CFParser Category Name Token -> CF.CF -> Category -> CF.CFParser +buildParser parser cf start tokens = (parseResults, parseInformation) + where parseInformation = prtSep "\n" trees + parseResults = [ (tree2cfTree t, []) | t <- trees ] + theInput = input tokens + edges = tracePrt "Parsing.CF - nr. edges" (prt.length) $ + parser pInf [start] theInput + chart = tracePrt "Parsing.CF - sz. chart" (prt . map (length.snd) . aAssocs) $ + grammar2chart $ map addCategory edges + forests = tracePrt "Parsing.CF - nr. forests" (prt.length) $ + chart2forests chart (const False) + [ uncurry Edge (inputBounds theInput) start ] + trees = tracePrt "Parsing.CF - nr. trees" (prt.length) $ + concatMap forest2trees forests + pInf = P.buildCFPInfo $ cf2grammar cf (nubsort tokens) + + +addCategory (CFRule cat rhs name) = CFRule cat rhs (name, cat) + +tree2cfTree (TNode (name, Edge _ _ cat) trees) = CF.CFTree (name, (cat, map tree2cfTree trees)) + +cf2grammar :: CF.CF -> [Token] -> CFGrammar Category Name Token +cf2grammar cf tokens = [ CFRule cat rhs name | + (name, (cat, rhs0)) <- cfRules, + rhs <- mapM item2symbol rhs0 ] + where cfRules = concatMap (CF.predefRules (CF.predefOfCF cf)) tokens ++ + CF.rulesOfCF cf + item2symbol (CF.CFNonterm cat) = [Cat cat] + item2symbol item = map Tok $ filter (CF.matchCFTerm item) tokens + + diff --git a/src-3.0/GF/Parsing/CFG.hs b/src-3.0/GF/Parsing/CFG.hs new file mode 100644 index 000000000..f64ce55f1 --- /dev/null +++ b/src-3.0/GF/Parsing/CFG.hs @@ -0,0 +1,51 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/11 10:28:16 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- CFG parsing +----------------------------------------------------------------------------- + +module GF.Parsing.CFG + (parseCF, module GF.Parsing.CFG.PInfo) where + +import GF.Data.Operations (Err(..)) + +import GF.Formalism.Utilities +import GF.Formalism.CFG +import GF.Parsing.CFG.PInfo + +import qualified GF.Parsing.CFG.Incremental as Inc +import qualified GF.Parsing.CFG.General as Gen + +---------------------------------------------------------------------- +-- parsing + +parseCF :: (Ord n, Ord c, Ord t) => String -> Err (CFParser c n t) + +parseCF "bottomup" = Ok $ Gen.parse bottomup +parseCF "topdown" = Ok $ Gen.parse topdown + +parseCF "gb" = Ok $ Gen.parse bottomup +parseCF "gt" = Ok $ Gen.parse topdown +parseCF "ib" = Ok $ Inc.parse (bottomup, noFilter) +parseCF "it" = Ok $ Inc.parse (topdown, noFilter) +parseCF "ibFT" = Ok $ Inc.parse (bottomup, topdown) +parseCF "ibFB" = Ok $ Inc.parse (bottomup, bottomup) +parseCF "ibFTB" = Ok $ Inc.parse (bottomup, bothFilters) +parseCF "itF" = Ok $ Inc.parse (topdown, bottomup) + +-- error parser: +parseCF prs = Bad $ "CFG parsing strategy not defined: " ++ prs + +bottomup = (True, False) +topdown = (False, True) +noFilter = (False, False) +bothFilters = (True, True) + + diff --git a/src-3.0/GF/Parsing/CFG/General.hs b/src-3.0/GF/Parsing/CFG/General.hs new file mode 100644 index 000000000..4f5959a85 --- /dev/null +++ b/src-3.0/GF/Parsing/CFG/General.hs @@ -0,0 +1,103 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:08 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- CFG parsing with a general chart +----------------------------------------------------------------------------- + +module GF.Parsing.CFG.General + (parse, Strategy) where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.Utilities +import GF.Formalism.CFG +import GF.Parsing.CFG.PInfo +import GF.Data.GeneralDeduction +import GF.Data.Assoc +import Control.Monad + +parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser c n t +parse strategy grammar start = extract . + tracePrt "Parsing.CFG.General - size internal of chart" + (prt . length . chartList) . + process strategy grammar start + +-- | parsing strategy: (isBottomup, isTopdown) +type Strategy = (Bool, Bool) + +extract :: (Ord n, Ord c, Ord t) => + IChart n (Symbol c t) -> CFChart c n t +extract chart = [ CFRule (Edge j k cat) daughters name | + Edge j k (Cat cat, found, [], Just name) <- chartList chart, + daughters <- path j k (reverse found) ] + where path i k [] = [ [] | i==k ] + path i k (Tok tok : found) + = [ Tok tok : daughters | + daughters <- path (i+1) k found ] + path i k (Cat cat : found) + = [ Cat (Edge i j cat) : daughters | + Edge _i j _cat <- chartLookup chart (Passive (Cat cat) i), + daughters <- path j k found ] + + +process :: (Ord n, Ord c, Ord t) => + Strategy -- ^ (isBottomup, isTopdown) :: (Bool, Bool) + -> CFPInfo c n t -- ^ parser information (= grammar) + -> [c] -- ^ list of starting categories + -> Input t -- ^ input string + -> IChart n (Symbol c t) +process (isBottomup, isTopdown) grammar start + = trace2 "Parsing.CFG.General - strategy" ((if isBottomup then " BU" else "") ++ + (if isTopdown then " TD" else "")) $ + buildChart keyof [predict, combine] . axioms + where axioms input = initial ++ scan input + + scan input = map (fmap mkEdge) (inputEdges input) + mkEdge tok = (Tok tok, [], [], Nothing) + + -- the combine rule + combine chart (Edge j k (next, _, [], _)) + = [ edge `forwardTo` k | edge <- chartLookup chart (Active next j) ] + combine chart edge@(Edge _ j (_, _, next:_, _)) + = [ edge `forwardTo` k | Edge _ k _ <- chartLookup chart (Passive next j) ] + + -- initial predictions + initial = [ loopingEdge 0 rule | cat <- start, rule <- tdRuleLookup ? cat ] + + -- predictions + predict chart (Edge j k (next, _, [], _)) | isBottomup + = [ loopingEdge j rule `forwardTo` k | rule <- bottomupRules grammar ? next ] + -- - - - - - - - - - ^^^^^^^^^^^^^ Kilbury prediction: move dot forward + predict chart (Edge _ k (_, _, Cat cat:_, _)) + = [ loopingEdge k rule | rule <- tdRuleLookup ? cat ] + predict _ _ = [] + + tdRuleLookup | isTopdown = topdownRules grammar + | isBottomup = emptyLeftcornerRules grammar + +-- internal representation of parse items + +type Item n s = Edge (s, [s], [s], Maybe n) +type IChart n s = ParseChart (Item n s) (IKey s) +data IKey s = Active s Int + | Passive s Int + deriving (Eq, Ord, Show) + +keyof (Edge _ j (_, _, next:_, _)) = Active next j +keyof (Edge j _ (cat, _, [], _)) = Passive cat j + +forwardTo (Edge i j (cat, found, next:tofind, name)) k + = Edge i k (cat, next:found, tofind, name) + +loopingEdge k (CFRule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name) + + + diff --git a/src-3.0/GF/Parsing/CFG/Incremental.hs b/src-3.0/GF/Parsing/CFG/Incremental.hs new file mode 100644 index 000000000..adab2b73c --- /dev/null +++ b/src-3.0/GF/Parsing/CFG/Incremental.hs @@ -0,0 +1,150 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:09 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- Incremental chart parsing for CFG +----------------------------------------------------------------------------- + + +module GF.Parsing.CFG.Incremental + (parse, Strategy) where + +import GF.System.Tracing +import GF.Infra.Print + +import Data.Array + +import GF.Data.Operations +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Formalism.Utilities +import GF.Formalism.CFG +import GF.Parsing.CFG.PInfo +import GF.Data.IncrementalDeduction + + +-- | parsing strategy: (predict:(BU, TD), filter:(BU, TD)) +type Strategy = ((Bool, Bool), (Bool, Bool)) + +parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser c n t +parse strategy grammar start = extract . + tracePrt "Parsing.CFG.Incremental - size of internal chart" + (prt . length . flip chartList const) . + process strategy grammar start + +extract :: (Ord n, Ord c, Ord t) => + IChart c n t -> CFChart c n t +extract finalChart = [ CFRule (Edge j k cat) daughters name | + (k, Item j (CFRule cat [] name) found) <- chartList finalChart (,), + daughters <- path j k (reverse found) ] + where path i k [] = [ [] | i==k ] + path i k (Tok tok : found) + = [ Tok tok : daughters | + daughters <- path (i+1) k found ] + path i k (Cat cat : found) + = [ Cat (Edge i j cat) : daughters | + Item j _ _ <- chartLookup finalChart i (Passive cat), + daughters <- path j k found ] + +process :: (Ord n, Ord c, Ord t) => + Strategy -> CFPInfo c n t -> [c] -> Input t -> IChart c n t +process ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input + = trace2 "Parsing.CFG.Incremental - strategy" ((if isPredictBU then "BU-predict " else "") ++ + (if isPredictTD then "TD-predict " else "") ++ + (if isFilterBU then "BU-filter " else "") ++ + (if isFilterTD then "TD-filter " else "")) $ + finalChart + where finalChart = buildChart keyof rules axioms $ inputBounds input + + axioms 0 = union $ map (tdInfer 0) start + axioms k = union [ buInfer j k (Tok token) | + (token, js) <- aAssocs (inputTo input ! k), j <- js ] + + rules k (Item j (CFRule cat [] _) _) + = buInfer j k (Cat cat) + rules k (Item j rule@(CFRule _ (sym@(Cat next):_) _) found) + = tdInfer k next <++> + -- hack for empty rules: + [ Item j (forward rule) (sym:found) | + emptyCategories grammar ?= next ] + rules _ _ = [] + + buInfer j k next = buPredict j k next <++> buCombine j k next + tdInfer k next = tdPredict k next + + -- the combine rule + buCombine j k next + | j == k = [] -- hack for empty rules, see rules above and tdPredict below + | otherwise = [ Item i (forward rule) (next:found) | + Item i rule found <- (finalChart ! j) ? Active next ] + + -- kilbury bottom-up prediction + buPredict j k next + = [ Item j rule [next] | isPredictBU, + rule <- map forward $ bottomupRules grammar ? next, + buFilter rule k, + tdFilter rule j k ] + + -- top-down prediction + tdPredict k cat + = [ Item k rule [] | isPredictTD || isFilterTD, + rule <- topdownRules grammar ? cat, + buFilter rule k ] <++> + -- hack for empty rules: + [ Item k rule [] | isPredictBU, + rule <- emptyLeftcornerRules grammar ? cat ] + + -- bottom up filtering: input symbol k can begin the given symbol list (first set) + -- leftcornerTokens DOESN'T WORK WITH EMPTY RULES!!! + buFilter (CFRule _ (Cat cat:_) _) k | isFilterBU + = k < snd (inputBounds input) && + hasCommonElements (leftcornerTokens grammar ? cat) + (aElems (inputFrom input ! k)) + buFilter _ _ = True + + -- top down filtering: 'cat' is reachable by an active edge ending in node j < k + tdFilter (CFRule cat _ _) j k | isFilterTD && j < k + = (tdFilters ! j) ?= cat + tdFilter _ _ _ = True + + tdFilters = listArray (inputBounds input) $ + map (listSet . limit leftCats . activeCats) [0..] + activeCats j = [ next | Active (Cat next) <- aElems (finalChart ! j) ] + leftCats cat = [ left | CFRule _cat (Cat left:_) _ <- topdownRules grammar ? cat ] + + +---------------------------------------------------------------------- +-- type declarations, items & keys + +data Item c n t = Item Int (CFRule c n t) [Symbol c t] + deriving (Eq, Ord, Show) + +data IKey c t = Active (Symbol c t) | Passive c + deriving (Eq, Ord, Show) + +type IChart c n t = IncrementalChart (Item c n t) (IKey c t) + +keyof :: Item c n t -> IKey c t +keyof (Item _ (CFRule _ (next:_) _) _) = Active next +keyof (Item _ (CFRule cat [] _) _) = Passive cat + +forward :: CFRule c n t -> CFRule c n t +forward (CFRule cat (_:rest) name) = CFRule cat rest name + +---------------------------------------------------------------------- + +instance (Print n, Print c, Print t) => Print (Item c n t) where + prt (Item k rule syms) + = "<"++show k++ ": "++ prt rule++" / "++prt syms++">" + +instance (Print c, Print t) => Print (IKey c t) where + prt (Active sym) = "?" ++ prt sym + prt (Passive cat) = "!" ++ prt cat + + diff --git a/src-3.0/GF/Parsing/CFG/PInfo.hs b/src-3.0/GF/Parsing/CFG/PInfo.hs new file mode 100644 index 000000000..f877b225e --- /dev/null +++ b/src-3.0/GF/Parsing/CFG/PInfo.hs @@ -0,0 +1,98 @@ +--------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/09 09:28:45 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- CFG parsing, parser information +----------------------------------------------------------------------------- + +module GF.Parsing.CFG.PInfo + (CFParser, CFPInfo(..), buildCFPInfo) where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.Utilities +import GF.Formalism.CFG +import GF.Data.SortedList +import GF.Data.Assoc + +---------------------------------------------------------------------- +-- type declarations + +-- | the list of categories = possible starting categories +type CFParser c n t = CFPInfo c n t + -> [c] + -> Input t + -> CFChart c n t + +------------------------------------------------------------ +-- parser information + +data CFPInfo c n t + = CFPInfo { grammarTokens :: SList t, + nameRules :: Assoc n (SList (CFRule c n t)), + topdownRules :: Assoc c (SList (CFRule c n t)), + bottomupRules :: Assoc (Symbol c t) (SList (CFRule c n t)), + emptyLeftcornerRules :: Assoc c (SList (CFRule c n t)), + emptyCategories :: Set c, + cyclicCategories :: SList c, + -- ^ ONLY FOR DIRECT CYCLIC RULES!!! + leftcornerTokens :: Assoc c (SList t) + -- ^ DOES NOT WORK WITH EMPTY RULES!!! + } + +buildCFPInfo :: (Ord c, Ord n, Ord t) => CFGrammar c n t -> CFPInfo c n t + +-- this is not permanent... +buildCFPInfo grammar = traceCalcFirst grammar $ + tracePrt "CFG.PInfo - parser info" (prt) $ + pInfo' (filter (not . isCyclic) grammar) + +pInfo' grammar = CFPInfo grToks nmRules tdRules buRules elcRules emptyCats cyclicCats leftToks + where grToks = union [ nubsort [ tok | Tok tok <- rhs ] | + CFRule _ rhs _ <- grammar ] + nmRules = accumAssoc id [ (name, rule) | + rule@(CFRule _ _ name) <- grammar ] + tdRules = accumAssoc id [ (cat, rule) | + rule@(CFRule cat _ _) <- grammar ] + buRules = accumAssoc id [ (next, rule) | + rule@(CFRule _ (next:_) _) <- grammar ] + elcRules = accumAssoc id $ limit lc emptyRules + leftToks = accumAssoc id $ limit lc $ + nubsort [ (cat, token) | + CFRule cat (Tok token:_) _ <- grammar ] + lc (left, res) = nubsort [ (cat, res) | + CFRule cat _ _ <- buRules ? Cat left ] + emptyRules = nubsort [ (cat, rule) | + rule@(CFRule cat [] _) <- grammar ] + emptyCats = listSet $ limitEmpties $ map fst emptyRules + limitEmpties es = if es==es' then es else limitEmpties es' + where es' = nubsort [ cat | CFRule cat rhs _ <- grammar, + all (symbol (\e -> e `elem` es) (const False)) rhs ] + cyclicCats = nubsort [ cat | CFRule cat [Cat cat'] _ <- grammar, cat == cat' ] + +isCyclic (CFRule cat [Cat cat'] _) = cat==cat' +isCyclic _ = False + + +---------------------------------------------------------------------- +-- pretty-printing of statistics + +instance (Ord c, Ord n, Ord t) => Print (CFPInfo c n t) where + prt pI = "[ tokens=" ++ sl grammarTokens ++ + "; names=" ++ sla nameRules ++ + "; tdCats=" ++ sla topdownRules ++ + "; buCats=" ++ sla bottomupRules ++ + "; elcCats=" ++ sla emptyLeftcornerRules ++ + "; eCats=" ++ sla emptyCategories ++ + -- "; cCats=" ++ sl cyclicCategories ++ + -- "; lctokCats=" ++ sla leftcornerTokens ++ + " ]" + where sla f = show $ length $ aElems $ f pI + sl f = show $ length $ f pI diff --git a/src-3.0/GF/Parsing/FCFG.hs b/src-3.0/GF/Parsing/FCFG.hs new file mode 100644 index 000000000..30a7801c8 --- /dev/null +++ b/src-3.0/GF/Parsing/FCFG.hs @@ -0,0 +1,100 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Parsing/FCFG/Active.hs b/src-3.0/GF/Parsing/FCFG/Active.hs new file mode 100644 index 000000000..df55793f8 --- /dev/null +++ b/src-3.0/GF/Parsing/FCFG/Active.hs @@ -0,0 +1,179 @@ +---------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Parsing/FCFG/Incremental.hs b/src-3.0/GF/Parsing/FCFG/Incremental.hs new file mode 100644 index 000000000..5ee77a061 --- /dev/null +++ b/src-3.0/GF/Parsing/FCFG/Incremental.hs @@ -0,0 +1,107 @@ +module GF.Parsing.FCFG.Incremental where + +import Data.Array +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Control.Monad + +import GF.Data.Assoc +import GF.Data.GeneralDeduction +import GF.Formalism.FCFG +import GF.Formalism.Utilities +import GF.Parsing.FCFG.PInfo +import GF.Parsing.FCFG.Range +import GF.GFCC.CId +import Debug.Trace + +initState :: FCFPInfo -> CId -> State +initState pinfo start = + let items = do + starts <- Map.lookup start (startupCats pinfo) + c <- starts + ruleid <- topdownRules pinfo ? c + let (FRule fn args cat lins) = allRules pinfo ! ruleid + lbl <- indices lins + return (Active 0 lbl 0 ruleid args cat) + + forest = IntMap.fromListWith Set.union [(cat, Set.singleton (Passive ruleid args)) | (ruleid, FRule _ args cat _) <- assocs (allRules pinfo)] + + max_fid = case IntMap.maxViewWithKey forest of + Just ((fid,_), _) -> fid+1 + Nothing -> 0 + + in process pinfo items (State emptyChart [] emptyChart Map.empty forest max_fid 0) + +nextState :: FCFPInfo -> FToken -> State -> State +nextState pinfo t state = + process pinfo (chartLookup (tokens state) t) state{ chart=emptyChart + , charts=chart state : charts state + , tokens=emptyChart + , passive=Map.empty + , currOffset=currOffset state+1 + } + +getCompletions :: State -> FToken -> [FToken] +getCompletions state w = + [t | t <- chartKeys (tokens state), take (length w) t == w] + +process pinfo [] state = state +process pinfo (item@(Active j lbl ppos ruleid args fid0):xitems) state + | inRange (bounds lin) ppos = + case lin ! ppos of + FSymCat _ r d -> let fid = args !! d + in case chartInsert (chart state) item (fid,r) of + Nothing -> process pinfo xitems state + Just actCat -> let items = do exprs <- IntMap.lookup fid (forest state) + (Passive ruleid args) <- Set.toList exprs + return (Active k r 0 ruleid args fid) + `mplus` + do id <- Map.lookup (fid,r,k) (passive state) + return (Active j lbl (ppos+1) ruleid (updateAt d id args) fid0) + in process pinfo (xitems++items) state{chart=actCat} + FSymTok tok -> case chartInsert (tokens state) (Active j lbl (ppos+1) ruleid args fid0) tok of + Nothing -> process pinfo xitems state + Just actTok -> process pinfo xitems state{tokens=actTok} + | otherwise = case Map.lookup (fid0, lbl, j) (passive state) of + Nothing -> let fid = nextId state + items = do Active j' lbl ppos ruleid args fidc <- chartLookup ((chart state:charts state) !! (k-j)) (fid0,lbl) + let FSymCat _ _ d = rhs ruleid lbl ! ppos + return (Active j' lbl (ppos+1) ruleid (updateAt d fid args) fidc) + in process pinfo (xitems++items) state{passive=Map.insert (fid0, lbl, j) fid (passive state) + ,forest =IntMap.insert fid (Set.singleton (Passive ruleid args)) (forest state) + ,nextId =nextId state+1 + } + Just id -> process pinfo xitems state{forest = IntMap.insertWith Set.union id (Set.singleton (Passive ruleid args)) (forest state)} + where + lin = rhs ruleid lbl + k = currOffset state + + rhs ruleid lbl = lins ! lbl + where + (FRule _ _ cat lins) = allRules pinfo ! ruleid + + updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] + + +data Active + = Active Int FIndex FPointPos RuleId [FCat] FCat + deriving (Eq,Show,Ord) +data Passive + = Passive RuleId [FCat] + deriving (Eq,Ord,Show) + + +data State + = State + { chart :: Chart + , charts :: [Chart] + , tokens :: ParseChart Active FToken + , passive :: Map.Map (FCat, FIndex, Int) FCat + , forest :: IntMap.IntMap (Set.Set Passive) + , nextId :: FCat + , currOffset :: Int + } + deriving Show + +type Chart = ParseChart Active (FCat, FIndex) diff --git a/src-3.0/GF/Parsing/FCFG/PInfo.hs b/src-3.0/GF/Parsing/FCFG/PInfo.hs new file mode 100644 index 000000000..8b288f2f1 --- /dev/null +++ b/src-3.0/GF/Parsing/FCFG/PInfo.hs @@ -0,0 +1,121 @@ +--------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Parsing/FCFG/Range.hs b/src-3.0/GF/Parsing/FCFG/Range.hs new file mode 100644 index 000000000..24674f58b --- /dev/null +++ b/src-3.0/GF/Parsing/FCFG/Range.hs @@ -0,0 +1,50 @@ +--------------------------------------------------------------------- +-- | +-- 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-3.0/GF/Parsing/GFC.hs b/src-3.0/GF/Parsing/GFC.hs new file mode 100644 index 000000000..9f1328a50 --- /dev/null +++ b/src-3.0/GF/Parsing/GFC.hs @@ -0,0 +1,208 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/13 12:40:19 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.9 $ +-- +-- The main parsing module, parsing GFC grammars +-- by translating to simpler formats, such as PMCFG and CFG +---------------------------------------------------------------------- + +module GF.Parsing.GFC + (parse, PInfo(..), buildPInfo) where + +import GF.System.Tracing +import GF.Infra.Print +import qualified GF.Grammar.PrGrammar as PrGrammar + +import GF.Data.ErrM + +import qualified GF.Grammar.Grammar as Grammar +import qualified GF.Grammar.Macros as Macros +import qualified GF.Canon.AbsGFC as AbsGFC +import qualified GF.GFCC.DataGFCC as AbsGFCC +import GF.GFCC.CId +import qualified GF.Infra.Ident as Ident +import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok) + +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Formalism.Utilities +import GF.Conversion.Types + +import qualified GF.Formalism.GCFG as G +import qualified GF.Formalism.SimpleGFC as S +import qualified GF.Formalism.MCFG as M +import GF.Formalism.FCFG +import qualified GF.Formalism.CFG as C +import qualified GF.Parsing.MCFG as PM +import qualified GF.Parsing.FCFG as PF +import qualified GF.Parsing.CFG as PC + +---------------------------------------------------------------------- +-- parsing information + +data PInfo = PInfo { mcfPInfo :: MCFPInfo + , fcfPInfo :: PF.FCFPInfo + , cfPInfo :: CFPInfo + } + +type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token +type CFPInfo = PC.CFPInfo CCat Name Token + +buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo +buildPInfo mcfg fcfg cfg = PInfo { mcfPInfo = PM.buildMCFPInfo mcfg + , fcfPInfo = PF.buildFCFPInfo fcfg + , cfPInfo = PC.buildCFPInfo cfg + } + +instance Print PInfo where + prt (PInfo m f c) = prt m ++ "\n" ++ prt c + +---------------------------------------------------------------------- +-- main parsing function + +parse :: String -- ^ parsing algorithm (mcfg or cfg) + -> String -- ^ parsing strategy + -> PInfo -- ^ compiled grammars (mcfg and cfg) + -> Ident.Ident -- ^ abstract module name + -> CFCat -- ^ starting category + -> [CFTok] -- ^ input tokens + -> Err [Grammar.Term] -- ^ resulting GF terms + + +-- parsing via CFG +parse "c" strategy pinfo abs startCat inString + = do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $ + inputMany (map wordsCFTok inString) + let startCats = tracePrt "Parsing.GFC - starting CF categories" prt $ + filter isStart $ map fst $ aAssocs $ PC.topdownRules cfpi + isStart cat = ccat2scat cat == cfCat2Ident startCat + cfpi = cfPInfo pinfo + cfParser <- PC.parseCF strategy + let cfChart = tracePrt "Parsing.GFC - CF chart" (prt . length) $ + cfParser cfpi startCats inTokens + chart = tracePrt "Parsing.GFC - chart" (prt . map (length.snd) . aAssocs) $ + C.grammar2chart cfChart + finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $ + map (uncurry Edge (inputBounds inTokens)) startCats + forests = chart2forests chart (const False) finalEdges + traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests)) + traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees))) + let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $ + forests >>= applyProfileToForest + -- compactFs = tracePrt "#compactForests" (prt . length) $ + -- tracePrt "compactForests" (prtBefore "\n") $ + -- compactForests forests + trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $ + nubsort $ filteredForests >>= forest2trees + -- compactFs >>= forest2trees + return $ map (tree2term abs) trees + + +-- parsing via MCFG +parse "m" strategy pinfo abs startCat inString + = do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $ + inputMany (map wordsCFTok inString) + let startCats = tracePrt "Parsing.GFC - starting MCF categories" prt $ + filter isStart $ PM.grammarCats mcfpi + isStart cat = mcat2scat cat == cfCat2Ident startCat + mcfpi = mcfPInfo pinfo + mcfParser <- PM.parseMCF strategy + let chart = mcfParser mcfpi startCats inTokens + finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $ + [ PM.makeFinalEdge cat lbl (inputBounds inTokens) | + cat@(MCat _ [lbl]) <- startCats ] + forests = chart2forests chart (const False) finalEdges + traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests)) + traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees))) + let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $ + forests >>= applyProfileToForest + -- compactFs = tracePrt "#compactForests" (prt . length) $ + -- tracePrt "compactForests" (prtBefore "\n") $ + -- compactForests forests + trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $ + nubsort $ filteredForests >>= forest2trees + -- compactFs >>= forest2trees + return $ map (tree2term abs) trees + + +-- parsing via FCFG +parse "f" strategy pinfo abs startCat inString = + let Ident.IC x = cfCat2Ident startCat + cat' = CId x + in case PF.parseFCF strategy (fcfPInfo pinfo) cat' (map prCFTok inString) of + Ok es -> Ok (map (exp2term abs) es) + Bad msg -> Bad msg + + +-- error parser: +selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy + +cnv_forests FMeta = FMeta +cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss) +cnv_forests (FString x) = FString x +cnv_forests (FInt x) = FInt x +cnv_forests (FFloat x) = FFloat x + +cnv_profile (Unify x) = Unify x +cnv_profile (Constant x) = Constant (cnv_forests2 x) + +cnv_forests2 FMeta = FMeta +cnv_forests2 (FNode (CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss) +cnv_forests2 (FString x) = FString x +cnv_forests2 (FInt x) = FInt x +cnv_forests2 (FFloat x) = FFloat x + +---------------------------------------------------------------------- +-- parse trees to GF terms + +tree2term :: Ident.Ident -> SyntaxTree Fun -> Grammar.Term +tree2term abs (TNode f ts) = Macros.mkApp (Macros.qq (abs,f)) (map (tree2term abs) ts) +tree2term abs (TString s) = Macros.string2term s +tree2term abs (TInt n) = Macros.int2term n +tree2term abs (TFloat f) = Macros.float2term f +tree2term abs (TMeta) = Macros.mkMeta 0 + +exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term +exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings + Macros.mkApp (atom2term abs a) (map (exp2term abs) es) + +atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term +atom2term abs (AbsGFCC.AC (CId f)) = Macros.qq (abs,Ident.IC f) +atom2term abs (AbsGFCC.AS s) = Macros.string2term s +atom2term abs (AbsGFCC.AI n) = Macros.int2term n +atom2term abs (AbsGFCC.AF f) = Macros.float2term f +atom2term abs (AbsGFCC.AM i) = Macros.mkMeta (fromInteger i) + +---------------------------------------------------------------------- +-- conversion and unification of forests + +-- simplest implementation +applyProfileToForest :: SyntaxForest Name -> [SyntaxForest Fun] +applyProfileToForest (FNode name@(Name fun profile) children) + | isCoercion name = concat chForests + | otherwise = [ FNode fun chForests | not (null chForests) ] + where chForests = concat [ applyProfileM unifyManyForests profile forests | + forests0 <- children, + forests <- mapM applyProfileToForest forests0 ] +applyProfileToForest (FString s) = [FString s] +applyProfileToForest (FInt n) = [FInt n] +applyProfileToForest (FFloat f) = [FFloat f] +applyProfileToForest (FMeta) = [FMeta] + +{- +-- more intelligent(?) implementation +applyProfileToForest (FNode (Name name profile) children) + | isCoercion name = concat chForests + | otherwise = [ FNode name chForests | not (null chForests) ] + where chForests = concat [ mapM (checkProfile forests) profile | + forests0 <- children, + forests <- mapM applyProfileToForest forests0 ] +-} + + diff --git a/src-3.0/GF/Parsing/MCFG.hs b/src-3.0/GF/Parsing/MCFG.hs new file mode 100644 index 000000000..bda3af675 --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG.hs @@ -0,0 +1,68 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/11 10:28:16 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- MCFG parsing +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG + (parseMCF, module GF.Parsing.MCFG.PInfo) where + +import GF.Data.Operations (Err(..)) + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Parsing.MCFG.PInfo + +import qualified GF.Parsing.MCFG.Naive as Naive +import qualified GF.Parsing.MCFG.Active as Active +import qualified GF.Parsing.MCFG.FastActive as FastActive +-- import qualified GF.Parsing.MCFG.Active2 as Active2 +import qualified GF.Parsing.MCFG.Incremental as Incremental +-- import qualified GF.Parsing.MCFG.Incremental2 as Incremental2 + +---------------------------------------------------------------------- +-- parsing + +parseMCF :: (Ord c, Ord n, Ord l, Ord t) => String -> Err (MCFParser c n l t) +parseMCF prs | prs `elem` strategies = Ok $ parseMCF' prs + | otherwise = Bad $ "MCFG parsing strategy not defined: " ++ prs + + +strategies = words "bottomup topdown n an ab at i rn ran rab rat ri ft fb" + + +parseMCF' :: (Ord c, Ord n, Ord l, Ord t) => String -> MCFParser c n l t + +parseMCF' "bottomup" pinfo starts toks = parseMCF' "fb" pinfo starts toks +parseMCF' "topdown" pinfo starts toks = parseMCF' "ft" pinfo starts toks + +parseMCF' "n" pinfo starts toks = Naive.parse pinfo starts toks +parseMCF' "an" pinfo starts toks = Active.parse "n" pinfo starts toks +parseMCF' "ab" pinfo starts toks = Active.parse "b" pinfo starts toks +parseMCF' "at" pinfo starts toks = Active.parse "t" pinfo starts toks +parseMCF' "i" pinfo starts toks = Incremental.parse pinfo starts toks + +-- parseMCF' "an2" pinfo starts toks = Active2.parse "n" pinfo starts toks +-- parseMCF' "ab2" pinfo starts toks = Active2.parse "b" pinfo starts toks +-- parseMCF' "at2" pinfo starts toks = Active2.parse "t" pinfo starts toks +-- parseMCF' "i2" pinfo starts toks = Incremental2.parse pinfo starts toks + +parseMCF' "rn" pinfo starts toks = Naive.parseR (rrP pinfo toks) starts +parseMCF' "ran" pinfo starts toks = Active.parseR "n" (rrP pinfo toks) starts +parseMCF' "rab" pinfo starts toks = Active.parseR "b" (rrP pinfo toks) starts +parseMCF' "rat" pinfo starts toks = Active.parseR "t" (rrP pinfo toks) starts +parseMCF' "ri" pinfo starts toks = Incremental.parseR (rrP pinfo toks) starts ntoks + where ntoks = snd (inputBounds toks) + +parseMCF' "fb" pinfo starts toks = FastActive.parse "b" (rrP pinfo toks) starts +parseMCF' "ft" pinfo starts toks = FastActive.parse "t" (rrP pinfo toks) starts + +rrP pi = rangeRestrictPInfo pi diff --git a/src-3.0/GF/Parsing/MCFG/Active.hs b/src-3.0/GF/Parsing/MCFG/Active.hs new file mode 100644 index 000000000..c6e9c6b06 --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/Active.hs @@ -0,0 +1,318 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- MCFG parsing, the active algorithm +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.Active (parse, parseR) where + +import GF.Data.GeneralDeduction +import GF.Data.Assoc + +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities + +import GF.Parsing.MCFG.Range +import GF.Parsing.MCFG.PInfo + +import GF.System.Tracing + +import Control.Monad (guard) + +import GF.Infra.Print + +---------------------------------------------------------------------- +-- * parsing + +parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t +parse strategy pinfo starts toks = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] + where chart = process strategy pinfo starts toks + +-- parseR :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t +parseR strategy pinfo starts = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] + where chart = processR strategy pinfo starts + +process :: (Ord n, Ord c, Ord l, Ord t) => + String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l +process strategy pinfo starts toks + = tracePrt "MCFG.Active - chart size" prtSizes $ + buildChart keyof (complete : combine : convert : rules) axioms + where rules | isNil strategy = [scan] + | isBU strategy = [scan, predictKilbury pinfo toks] + | isTD strategy = [scan, predictEarley pinfo toks] + axioms | isNil strategy = predict pinfo toks + | isBU strategy = {- terminal pinfo toks ++ -} initialScan pinfo toks + | isTD strategy = initial pinfo starts toks + +--processR :: (Ord n, Ord c, Ord l) => +-- String -> MCFPInfo c n l Range -> [c] -> AChart c n l +processR strategy pinfo starts + = tracePrt "MCFG.Active Range - chart size" prtSizes $ + -- tracePrt "MCFG.Active Range - final chart" prtChart $ + buildChart keyof (complete : combine : convert : rules) axioms + where rules | isNil strategy = [scan] + | isBU strategy = [scan, predictKilburyR pinfo] + | isTD strategy = [scan, predictEarleyR pinfo] + axioms | isNil strategy = predictR pinfo + | isBU strategy = {- terminalR pinfo ++ -} initialScanR pinfo + | isTD strategy = initialR pinfo starts + +isNil s = s=="n" +isBU s = s=="b" +isTD s = s=="t" + +-- used in prediction +emptyChildren :: Abstract c n -> [RangeRec l] +emptyChildren (Abs _ rhs _) = replicate (length rhs) [] + +makeMaxRange (Range (_, j)) = Range (j, j) +makeMaxRange EmptyRange = EmptyRange + + +---------------------------------------------------------------------- +-- * inference rules + +-- completion +complete :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] +complete _ (Active rule found rng (Lin l []) (lin:lins) recs) = + return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs +complete _ _ = [] + +-- scanning +scan :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] +scan _ (Active rule found rng (Lin l (Tok rng':syms)) lins recs) = + do rng'' <- concatRange rng rng' + return $ Active rule found rng'' (Lin l syms) lins recs +scan _ _ = [] + +-- | Creates an Active Item every time it is possible to combine +-- an Active Item from the agenda with a Passive Item from the Chart +combine :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] +combine chart item@(Active _ _ _ (Lin _ (Cat (c,_,_):_)) _ _) = + do Passive _c found <- chartLookup chart (Pass c) + combine2 chart found item +combine chart (Passive c found) = + do item <- chartLookup chart (Act c) + combine2 chart found item +combine _ _ = [] + +combine2 chart found' (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) = + do rng' <- projection r found' + rng'' <- concatRange rng rng' + recs' <- unifyRec recs d found' + return $ Active rule found rng'' (Lin l syms) lins recs' + +-- | Active Items with nothing to find are converted to Final items, +-- which in turn are converted to Passive Items +convert :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l] +convert _ (Active rule found rng (Lin lbl []) [] recs) = + return $ Final rule (found ++ [(lbl,rng)]) recs +convert _ (Final (Abs cat _ _) found _) = + return $ Passive cat found +convert _ _ = [] + + +---------------------------------------------------------------------- +-- Naive -- + +predict :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] +predict pinfo toks = tracePrt "MCFG.Active (Naive) - predicted rules" (prt . length) $ + do (Rule abs (Cnc _ _ lins)) <- rulesMatchingInput pinfo toks + (lin':lins') <- rangeRestRec toks lins + return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs) + + +---------------------------------------------------------------------- +-- NaiveR -- + +predictR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] +predictR pinfo = tracePrt "MCFG.Active (Naive Range) - predicted rules" (prt . length) $ + do (Rule abs (Cnc _ _ (lin:lins))) <- allRules pinfo + return $ Active abs [] EmptyRange lin lins (emptyChildren abs) + + +---------------------------------------------------------------------- +-- Earley -- + +-- anropas med alla startkategorier +initial :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> [c] -> Input t -> [Item c n l] +initial pinfo starts toks = + tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $ + do cat <- starts + Rule abs (Cnc _ _ lins) <- topdownRules pinfo ? cat + lin' : lins' <- rangeRestRec toks lins + return $ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs) + +predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t + -> AChart c n l -> Item c n l -> [Item c n l] +predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = + topdownRules pinfo ? cat >>= predictEarley2 toks rng +predictEarley _ _ _ _ = [] + +predictEarley2 :: (Ord c, Ord n, Ord l, Ord t) => Input t -> Range -> MCFRule c n l t -> [Item c n l] +predictEarley2 toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = + do lins' <- rangeRestRec toks lins + return $ Final abs (makeRangeRec lins') [] +predictEarley2 toks rng (Rule abs (Cnc _ _ lins)) = + do lin' : lins' <- rangeRestRec toks lins + return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs) + + +---------------------------------------------------------------------- +-- Earley Range -- + +initialR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [c] -> [Item c n l] +initialR pinfo starts = + tracePrt "MCFG.Active (Earley Range) - initial rules" (prt . length) $ + do cat <- starts + Rule abs (Cnc _ _ (lin : lins)) <- topdownRules pinfo ? cat + return $ Active abs [] (Range (0, 0)) lin lins (emptyChildren abs) + +predictEarleyR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range + -> AChart c n l -> Item c n l -> [Item c n l] +predictEarleyR pinfo _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = + topdownRules pinfo ? cat >>= predictEarleyR2 rng +predictEarleyR _ _ _ = [] + +predictEarleyR2 :: (Ord c, Ord n, Ord l) => Range -> MCFRule c n l Range -> [Item c n l] +predictEarleyR2 _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = + return $ Final abs (makeRangeRec lins) [] +predictEarleyR2 rng (Rule abs (Cnc _ _ (lin : lins))) = + return $ Active abs [] EmptyRange lin lins (emptyChildren abs) + + +---------------------------------------------------------------------- +-- Kilbury -- + +-- terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] +-- terminal pinfo toks = +-- tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $ +-- do Rule abs (Cnc _ _ lins) <- emptyRules pinfo +-- lins' <- rangeRestRec toks lins +-- return $ Final abs (makeRangeRec lins') [] + +initialScan :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] +initialScan pinfo toks = + tracePrt "MCFG.Active (Kilbury) - initial scanned rules + epsilon rules" (prt . length) $ + do tok <- aElems (inputToken toks) + Rule abs (Cnc _ _ lins) <- + leftcornerTokens pinfo ? tok ++ + epsilonRules pinfo + lin' : lins' <- rangeRestRec toks lins + return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs) + +predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t + -> AChart c n l -> Item c n l -> [Item c n l] +predictKilbury pinfo toks _ (Passive cat found) = + do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat + lin' : lins' <- rangeRestRec toks (Lin l syms : lins) + rng <- projection r found + children <- unifyRec (emptyChildren abs) i found + return $ Active abs [] rng lin' lins' children +predictKilbury _ _ _ _ = [] + + + +---------------------------------------------------------------------- +-- KilburyR -- + +-- terminalR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] +-- terminalR pinfo = +-- tracePrt "MCFG.Active (Kilbury Range) - initial terminal rules" (prt . length) $ +-- do Rule abs (Cnc _ _ lins) <- emptyRules pinfo +-- return $ Final abs (makeRangeRec lins) [] + +initialScanR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] +initialScanR pinfo = + tracePrt "MCFG.Active (Kilbury Range) - initial scanned rules" (prt . length) $ + do Rule abs (Cnc _ _ (lin : lins)) <- + concatMap snd (aAssocs (leftcornerTokens pinfo)) ++ + epsilonRules pinfo + return $ Active abs [] EmptyRange lin lins (emptyChildren abs) + +predictKilburyR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range + -> AChart c n l -> Item c n l -> [Item c n l] +predictKilburyR pinfo _ (Passive cat found) = + do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat + rng <- projection r found + children <- unifyRec (emptyChildren abs) i found + return $ Active abs [] rng (Lin l syms) lins children +predictKilburyR _ _ _ = [] + + +---------------------------------------------------------------------- +-- * type definitions + +type AChart c n l = ParseChart (Item c n l) (AKey c) + +data Item c n l = Active (Abstract c n) + (RangeRec l) + Range + (Lin c l Range) + (LinRec c l Range) + [RangeRec l] + | Final (Abstract c n) (RangeRec l) [RangeRec l] + | Passive c (RangeRec l) + deriving (Eq, Ord, Show) + +data AKey c = Act c + | Pass c + | Useless + | Fin + deriving (Eq, Ord, Show) + + +keyof :: Item c n l -> AKey c +keyof (Active _ _ _ (Lin _ (Cat (next, _, _):_)) _ _) = Act next +keyof (Final _ _ _) = Fin +keyof (Passive cat _) = Pass cat +keyof _ = Useless + + +---------------------------------------------------------------------- +-- for tracing purposes + +prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++ + ", passive=" ++ show (sum [length (chartLookup chart k) | + k@(Pass _) <- chartKeys chart ]) ++ + ", active=" ++ show (sum [length (chartLookup chart k) | + k@(Act _) <- chartKeys chart ]) ++ + ", useless=" ++ show (length (chartLookup chart Useless)) + +prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ + prtBefore "\n " (chartLookup chart k) | + k <- chartKeys chart ] + +prtFinals chart = prtBefore "\n " (chartLookup chart Fin) + +instance (Print c, Print n, Print l) => Print (Item c n l) where + prt (Active abs found rng lin tofind children) = + "? " ++ prt abs ++ ";\n\t" ++ + "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ + prt lin ++ " {" ++ prtSep " " tofind ++ "}" ++ + ( if null children then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) + prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" + prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ + ( if null rrs then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) + +instance Print c => Print (AKey c) where + prt (Act c) = "Active " ++ prt c + prt (Pass c) = "Passive " ++ prt c + prt (Fin) = "Final" + prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/Active2.hs b/src-3.0/GF/Parsing/MCFG/Active2.hs new file mode 100644 index 000000000..7ad8627bc --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/Active2.hs @@ -0,0 +1,237 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.2 $ +-- +-- MCFG parsing, the active algorithm (alternative version) +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.Active2 (parse) where + +import GF.Data.GeneralDeduction +import GF.Data.Assoc + +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities + +import GF.Parsing.MCFG.Range +import GF.Parsing.MCFG.PInfo + +import GF.System.Tracing + +import Control.Monad (guard) + +import GF.Infra.Print + +---------------------------------------------------------------------- +-- * parsing + +--parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t +parse strategy pinfo starts toks = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] + where chart = process strategy pinfo starts toks + +process :: (Ord n, Ord c, Ord l, Ord t) => + String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l t +process strategy pinfo starts toks + = tracePrt "MCFG.Active - chart size" prtSizes $ + buildChart keyof (complete : combine : convert : rules) axioms + where rules | isNil strategy = [scan toks] + | isBU strategy = [scan toks, predictKilbury pinfo toks] + | isTD strategy = [scan toks, predictEarley pinfo toks] + axioms | isNil strategy = predict pinfo toks + | isBU strategy = terminal pinfo toks ++ initialScan pinfo toks + | isTD strategy = initial pinfo starts toks + +isNil s = s=="n" +isBU s = s=="b" +isTD s = s=="t" + +-- used in prediction +emptyChildren :: Abstract c n -> [RangeRec l] +emptyChildren (Abs _ rhs _) = replicate (length rhs) [] + +makeMaxRange (Range (_, j)) = Range (j, j) +makeMaxRange EmptyRange = EmptyRange + + +---------------------------------------------------------------------- +-- * inference rules + +-- completion +complete :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] +complete _ (Active rule found rng (Lin l []) (lin:lins) recs) = + return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs +complete _ _ = [] + +-- scanning +--scan :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] +scan inp _ (Active rule found rng (Lin l (Tok tok:syms)) lins recs) = + do rng' <- map makeRange (inputToken inp ? tok) + rng'' <- concatRange rng rng' + return $ Active rule found rng'' (Lin l syms) lins recs +scan _ _ _ = [] + +-- | Creates an Active Item every time it is possible to combine +-- an Active Item from the agenda with a Passive Item from the Chart +combine :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] +combine chart item@(Active _ _ _ (Lin _ (Cat (c,_,_):_)) _ _) = + do Passive _c found <- chartLookup chart (Pass c) + combine2 chart found item +combine chart (Passive c found) = + do item <- chartLookup chart (Act c) + combine2 chart found item +combine _ _ = [] + +combine2 chart found' (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) = + do rng' <- projection r found' + rng'' <- concatRange rng rng' + recs' <- unifyRec recs d found' + return $ Active rule found rng'' (Lin l syms) lins recs' + +-- | Active Items with nothing to find are converted to Final items, +-- which in turn are converted to Passive Items +convert :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t] +convert _ (Active rule found rng (Lin lbl []) [] recs) = + return $ Final rule (found ++ [(lbl,rng)]) recs +convert _ (Final (Abs cat _ _) found _) = + return $ Passive cat found +convert _ _ = [] + + +---------------------------------------------------------------------- +-- Naive -- + +predict :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t] +predict pinfo toks = tracePrt "MCFG.Active (Naive) - predicted rules" (prt . length) $ + do Rule abs (Cnc _ _ (lin:lins)) <- rulesMatchingInput pinfo toks + return $ Active abs [] EmptyRange lin lins (emptyChildren abs) + + +---------------------------------------------------------------------- +-- Earley -- + +-- anropas med alla startkategorier +initial :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> [c] -> Input t -> [Item c n l t] +initial pinfo starts toks = + tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $ + do cat <- starts + Rule abs (Cnc _ _ (lin:lins)) <- topdownRules pinfo ? cat + return $ Active abs [] (Range (0, 0)) lin lins (emptyChildren abs) + +predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t + -> AChart c n l t -> Item c n l t -> [Item c n l t] +predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = + topdownRules pinfo ? cat >>= predictEarley2 toks rng +predictEarley _ _ _ _ = [] + +predictEarley2 :: (Ord c, Ord n, Ord l, Ord t) => Input t -> Range -> MCFRule c n l t -> [Item c n l t] +predictEarley2 toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = + do lins' <- rangeRestRec toks lins + return $ Final abs (makeRangeRec lins') [] +predictEarley2 toks rng (Rule abs (Cnc _ _ (lin:lins))) = + return $ Active abs [] EmptyRange lin lins (emptyChildren abs) + + +---------------------------------------------------------------------- +-- Kilbury -- + +terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t] +terminal pinfo toks = + tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $ + do Rule abs (Cnc _ _ lins) <- emptyRules pinfo + lins' <- rangeRestRec toks lins + return $ Final abs (makeRangeRec lins') [] + +initialScan :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t] +initialScan pinfo toks = + tracePrt "MCFG.Active (Kilbury) - initial scanned rules" (prt . length) $ + do tok <- aElems (inputToken toks) + Rule abs (Cnc _ _ (lin:lins)) <- leftcornerTokens pinfo ? tok + return $ Active abs [] EmptyRange lin lins (emptyChildren abs) + +predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t + -> AChart c n l t -> Item c n l t -> [Item c n l t] +predictKilbury pinfo toks _ (Passive cat found) = + do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat + rng <- projection r found + children <- unifyRec (emptyChildren abs) i found + return $ Active abs [] rng (Lin l syms) lins children +predictKilbury _ _ _ _ = [] + + +---------------------------------------------------------------------- +-- * type definitions + +type AChart c n l t = ParseChart (Item c n l t) (AKey c t) + +data Item c n l t = Active (Abstract c n) + (RangeRec l) + Range + (Lin c l t) + (LinRec c l t) + [RangeRec l] + | Final (Abstract c n) (RangeRec l) [RangeRec l] + | Passive c (RangeRec l) + deriving (Eq, Ord, Show) + +data AKey c t = Act c + | ActTok t + | Pass c + | Useless + | Fin + deriving (Eq, Ord, Show) + + +keyof :: Item c n l t -> AKey c t +keyof (Active _ _ _ (Lin _ (Cat (next, _, _):_)) _ _) = Act next +keyof (Active _ _ _ (Lin _ (Tok tok:_)) _ _) = ActTok tok +keyof (Final _ _ _) = Fin +keyof (Passive cat _) = Pass cat +keyof _ = Useless + + +---------------------------------------------------------------------- +-- for tracing purposes + +prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++ + ", passive=" ++ show (sum [length (chartLookup chart k) | + k@(Pass _) <- chartKeys chart ]) ++ + ", active=" ++ show (sum [length (chartLookup chart k) | + k@(Act _) <- chartKeys chart ]) ++ + ", active-tok=" ++ show (sum [length (chartLookup chart k) | + k@(ActTok _) <- chartKeys chart ]) ++ + ", useless=" ++ show (length (chartLookup chart Useless)) + +prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ + prtBefore "\n " (chartLookup chart k) | + k <- chartKeys chart ] + +prtFinals chart = prtBefore "\n " (chartLookup chart Fin) + +instance (Print c, Print n, Print l, Print t) => Print (Item c n l t) where + prt (Active abs found rng lin tofind children) = + "? " ++ prt abs ++ ";\n\t" ++ + "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ + prt lin ++ " {" ++ prtSep " " tofind ++ "}" ++ + ( if null children then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) + prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" + prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ + ( if null rrs then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) + +instance (Print c, Print t) => Print (AKey c t) where + prt (Act c) = "Active " ++ prt c + prt (ActTok t) = "Active-Tok " ++ prt t + prt (Pass c) = "Passive " ++ prt c + prt (Fin) = "Final" + prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/FastActive.hs b/src-3.0/GF/Parsing/MCFG/FastActive.hs new file mode 100644 index 000000000..0a8e24b55 --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/FastActive.hs @@ -0,0 +1,176 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- MCFG parsing, the active algorithm, optimized version +-- structure stolen from Krasimir Angelov's GF.Parsing.FCFG.Active +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.FastActive (parse) where + +import GF.Data.GeneralDeduction +import GF.Data.Assoc +import GF.Data.Utilities + +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities + +import GF.Infra.Ident + +import GF.Parsing.MCFG.Range +import GF.Parsing.MCFG.PInfo + +import GF.System.Tracing + +import Control.Monad (guard) + +import GF.Infra.Print + +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Array + +---------------------------------------------------------------------- +-- * parsing + +-- parse :: (Ord c, Ord n, Ord l, Ord t) => String -> MCFParser c n l t +parse strategy pinfo starts = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + Final (Abs cat rhs fun) found rrecs <- listXChartFinal chart ] + where chart = process strategy pinfo axioms emptyXChart + + -- axioms | isBU strategy = terminal pinfo toks ++ initialScan pinfo toks + axioms | isBU strategy = initialBU pinfo + | isTD strategy = initialTD pinfo starts + +isBU s = s=="b" +isTD s = s=="t" + +-- used in prediction +emptyChildren :: Abstract c n -> [RangeRec l] +emptyChildren (Abs _ rhs _) = replicate (length rhs) [] + +updateChildren :: Eq l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]] +updateChildren recs i rec = updateNthM update i recs + where update rec' = do guard (null rec' || rec' == rec) + return rec + +process :: (Ord c, Ord n, Ord l) => String -> MCFPInfo c n l Range -> [Item c n l] -> XChart c n l -> XChart c n l +process strategy pinfo [] chart = chart +process strategy pinfo (item:items) chart = process strategy pinfo items $! univRule item chart + where + univRule item@(Active abs found rng (Lin l syms) lins recs) chart + = case syms of + Cat(c,r,d) : syms' -> + case insertXChart chart item c of + Nothing -> chart + Just chart -> + let items = -- predict topdown + [ Active abs [] EmptyRange lin lins (emptyChildren abs) | + isTD strategy, + Rule abs (Cnc _ _ (lin:lins)) <- topdownRules pinfo ? c ] ++ + + -- combine + [ Active abs found rng'' (Lin l syms') lins recs' | + Final _ found' _ <- lookupXChartFinal chart c, + rng' <- projection r found', + rng'' <- concatRange rng rng', + recs' <- updateChildren recs d found' ] + in process strategy pinfo items chart + + -- scan + Tok rng' : syms' -> + let items = [ Active abs found rng'' (Lin l syms') lins recs | + rng'' <- concatRange rng rng' ] + in process strategy pinfo items chart + + -- complete + [] -> case lins of + (lin':lins') -> univRule (Active abs ((l,rng):found) EmptyRange lin' lins' recs) chart + [] -> univRule (Final abs (reverse ((l,rng):found)) recs) chart + + univRule item@(Final abs@(Abs cat _ _) found' recs) chart = + case insertXChart chart item cat of + Nothing -> chart + Just chart -> + let items = -- predict bottomup + [ Active abs [] rng (Lin l syms') lins children | + isBU strategy, + Rule abs (Cnc _ _ (Lin l (Cat(c,r,d):syms') : lins)) <- leftcornerCats pinfo ? cat, + -- lin' : lins' <- rangeRestRec toks (Lin l syms' : lins), + rng <- projection r found', + children <- unifyRec (emptyChildren abs) d found' ] ++ + + -- combine + [ Active abs found rng'' (Lin l syms') lins recs' | + Active abs found rng (Lin l (Cat(c,r,d):syms')) lins recs <- lookupXChartAct chart cat, + rng' <- projection r found', + rng'' <- concatRange rng rng', + recs' <- updateChildren recs d found' ] + in process strategy pinfo items chart + +---------------------------------------------------------------------- +-- * XChart + +data XChart c n l = XChart !(AChart c n l) !(AChart c n l) +type AChart c n l = ParseChart (Item c n l) c + +data Item c n l = Active (Abstract c n) + (RangeRec l) + Range + (Lin c l Range) + (LinRec c l Range) + [RangeRec l] + | Final (Abstract c n) (RangeRec l) [RangeRec l] +-- | Passive c (RangeRec l) + deriving (Eq, Ord, Show) + +emptyXChart :: (Ord c, Ord n, Ord l) => XChart c n l +emptyXChart = XChart emptyChart emptyChart + +insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _) c = + case chartInsert actives item c of + Nothing -> Nothing + Just actives -> Just (XChart actives finals) + +insertXChart (XChart actives finals) item@(Final _ _ _) c = + case chartInsert finals item c of + Nothing -> Nothing + Just finals -> Just (XChart actives finals) + +lookupXChartAct (XChart actives finals) c = chartLookup actives c +lookupXChartFinal (XChart actives finals) c = chartLookup finals c + +listXChartAct (XChart actives finals) = chartList actives +listXChartFinal (XChart actives finals) = chartList finals + + +---------------------------------------------------------------------- +-- Earley -- + +-- called with all starting categories +initialTD :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [c] -> [Item c n l] +initialTD pinfo starts = + [ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs) | + cat <- starts, + Rule abs (Cnc _ _ (lin':lins')) <- topdownRules pinfo ? cat ] + -- lin' : lins' <- rangeRestRec toks lins + + +---------------------------------------------------------------------- +-- Kilbury -- + +initialBU :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] +initialBU pinfo = + [ Active abs [] EmptyRange lin' lins' (emptyChildren abs) | + -- do tok <- aElems (inputToken toks) + Rule abs (Cnc _ _ (lin':lins')) <- + concatMap snd (aAssocs (leftcornerTokens pinfo)) ++ + -- leftcornerTokens pinfo ? tok ++ + epsilonRules pinfo ] + -- lin' : lins' <- rangeRestRec toks lins diff --git a/src-3.0/GF/Parsing/MCFG/Incremental.hs b/src-3.0/GF/Parsing/MCFG/Incremental.hs new file mode 100644 index 000000000..bd5b4114d --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/Incremental.hs @@ -0,0 +1,178 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.4 $ +-- +-- MCFG parsing, the incremental algorithm +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.Incremental (parse, parseR) where + +import Data.List +import Control.Monad (guard) + +import GF.Data.Utilities (select) +import GF.Data.GeneralDeduction +import GF.Data.Assoc + +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities + +import GF.Parsing.MCFG.Range +import GF.Parsing.MCFG.PInfo + +import GF.System.Tracing +import GF.Infra.Print + +---------------------------------------------------------------------- +-- parsing + +parse :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t +parse pinfo starts toks = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] + where chart = process pinfo toks ntoks + ntoks = snd (inputBounds toks) + +-- parseR :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t +parseR pinfo starts ntoks = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] + where chart = processR pinfo ntoks + +process :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> IChart c n l +process pinfo toks ntoks + = tracePrt "MCFG.Incremental - chart size" prtSizes $ + buildChart keyof [complete ntoks, scan, combine, convert] (predict pinfo toks ntoks) + +processR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> Int -> IChart c n l +processR pinfo ntoks + = tracePrt "MCFG.Incremental Range - chart size" prtSizes $ + buildChart keyof [complete ntoks, scan, combine, convert] (predictR pinfo ntoks) + +complete :: (Ord n, Ord c, Ord l) => Int -> IChart c n l -> Item c n l -> [Item c n l] +complete ntoks _ (Active rule found rng (Lin l []) lins recs) = + do (lin, lins') <- select lins + k <- [minRange rng .. ntoks] + return $ Active rule (found ++ [(l, rng)]) (Range (k,k)) lin lins' recs +complete _ _ _ = [] + + +predict :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> [Item c n l] +predict pinfo toks n = + tracePrt "MCFG.Incremental - predicted rules" (prt . length) $ + do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo toks + let daughters = replicate (length rhs) [] + lins' <- rangeRestRec toks lins + (lin', lins'') <- select lins' + k <- [0..n] + return $ Active abs [] (Range (k,k)) lin' lins'' daughters + + +predictR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> Int -> [Item c n l] +predictR pinfo n = + tracePrt "MCFG.Incremental Range - predicted rules" (prt . length) $ + do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- allRules pinfo + let daughters = replicate (length rhs) [] + (lin, lins') <- select lins + k <- [0..n] + return $ Active abs [] (Range (k,k)) lin lins' daughters + + +scan :: (Ord n, Ord c, Ord l) => IChart c n l -> Item c n l -> [Item c n l] +scan _ (Active abs found rng (Lin l (Tok rng':syms)) lins recs) = + do rng'' <- concatRange rng rng' + return $ Active abs found rng'' (Lin l syms) lins recs +scan _ _ = [] + + +combine :: (Ord n, Ord c, Ord l) => IChart c n l -> Item c n l -> [Item c n l] +combine chart active@(Active _ _ rng (Lin _ (Cat (c,l,_):_)) _ _) = + do passive <- chartLookup chart (Pass c l (maxRange rng)) + combine2 active passive +combine chart passive@(Active (Abs c _ _) _ rng (Lin l []) _ _) = + do active <- chartLookup chart (Act c l (minRange rng)) + combine2 active passive +combine _ _ = [] + +combine2 (Active abs found rng (Lin l (Cat (c,l',d):syms)) lins recs) + (Active _ found' rng' _ _ _) + = do rng'' <- concatRange rng rng' + recs' <- unifyRec recs d found'' + return $ Active abs found rng'' (Lin l syms) lins recs' + where found'' = found' ++ [(l',rng')] + + +convert _ (Active rule found rng (Lin lbl []) [] recs) = + return $ Final rule (found ++ [(lbl,rng)]) recs +convert _ _ = [] + +---------------------------------------------------------------------- +-- type definitions + +type IChart c n l = ParseChart (Item c n l) (IKey c l) + +data Item c n l = Active (Abstract c n) + (RangeRec l) + Range + (Lin c l Range) + (LinRec c l Range) + [RangeRec l] + | Final (Abstract c n) (RangeRec l) [RangeRec l] +-- | Passive c (RangeRec l) + deriving (Eq, Ord, Show) + +data IKey c l = Act c l Int + | Pass c l Int + | Useless + | Fin + deriving (Eq, Ord, Show) + +keyof :: Item c n l -> IKey c l +keyof (Active _ _ rng (Lin _ (Cat (next,lbl,_):_)) _ _) + = Act next lbl (maxRange rng) +keyof (Active (Abs cat _ _) found rng (Lin lbl []) _ _) + = Pass cat lbl (minRange rng) +keyof (Final _ _ _) = Fin +keyof _ + = Useless + + +---------------------------------------------------------------------- +-- for tracing purposes +prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++ + ", passive=" ++ show (sum [length (chartLookup chart k) | + k@(Pass _ _ _) <- chartKeys chart ]) ++ + ", active=" ++ show (sum [length (chartLookup chart k) | + k@(Act _ _ _) <- chartKeys chart ]) ++ + ", useless=" ++ show (length (chartLookup chart Useless)) + +prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ + prtBefore "\n " (chartLookup chart k) | + k <- chartKeys chart ] + +instance (Print c, Print n, Print l) => Print (Item c n l) where + prt (Active abs found rng lin tofind children) = + "? " ++ prt abs ++ ";\n\t" ++ + "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ + prt lin ++ "{" ++ prtSep " " tofind ++ "}" ++ + ( if null children then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) +-- prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" + prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ + ( if null rrs then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) + +instance (Print c, Print l) => Print (IKey c l) where + prt (Act c l i) = "Active " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i + prt (Pass c l i) = "Passive " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i + prt (Fin) = "Final" + prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/Incremental2.hs b/src-3.0/GF/Parsing/MCFG/Incremental2.hs new file mode 100644 index 000000000..db6c3084e --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/Incremental2.hs @@ -0,0 +1,157 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.3 $ +-- +-- MCFG parsing, the incremental algorithm (alternative version) +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.Incremental2 (parse) where + +import Data.List +import Data.Array +import Control.Monad (guard) + +import GF.Data.Utilities (select) +import GF.Data.Assoc +import GF.Data.IncrementalDeduction + +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities + +import GF.Parsing.MCFG.Range +import GF.Parsing.MCFG.PInfo + +import GF.System.Tracing +import GF.Infra.Print + +---------------------------------------------------------------------- +-- parsing + +-- parseR :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t +parse pinfo starts inp = + accumAssoc groupSyntaxNodes $ + [ ((cat, found), SNode fun (zip rhs rrecs)) | + k <- uncurry enumFromTo (inputBounds inp), + Final (Abs cat rhs fun) found rrecs <- chartLookup chart k Fin ] + where chart = process pinfo inp + +--process :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> (Int, Int) -> IChart c n l +process pinfo inp + = tracePrt "MCFG.Incremental - chart size" + (prt . map (prtSizes finalChart . fst) . assocs) $ + finalChart + where finalChart = buildChart keyof rules axioms inBounds + axioms k = tracePrt ("MCFG.Incremental - axioms for " ++ show k) (prt . length) $ + predict k ++ scan k ++ complete1 k + rules k item = complete2 k item ++ combine k item ++ convert k item + inBounds = inputBounds inp + + -- axioms: predict + scan + complete + predict k = do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo inp + let daughters = replicate (length rhs) [] + (lin, lins') <- select lins + return $ Active abs [] k lin lins' daughters + + scan k = do (tok, js) <- aAssocs (inputTo inp ! k) + j <- js + Active abs found i (Lin l (Tok _tok:syms)) lins recs <- + chartLookup finalChart j (ActTok tok) + return $ Active abs found i (Lin l syms) lins recs + + complete1 k = do j <- [fst inBounds .. k-1] + Active abs found i (Lin l _Nil) lins recs <- + chartLookup finalChart j Pass + let found' = found ++ [(l, makeRange (i,j))] + (lin, lins') <- select lins + return $ Active abs found' k lin lins' recs + + -- rules: convert + combine + complete + convert k (Active rule found j (Lin lbl []) [] recs) = + let found' = found ++ [(lbl, makeRange (j,k))] + in return $ Final rule found' recs + convert _ _ = [] + + combine k (Active (Abs cat _ _) found' j (Lin lbl []) _ _) = + do guard (j < k) ---- cannot handle epsilon-rules + Active abs found i (Lin l (Cat (_cat,_lbl,nr):syms)) lins recs <- + chartLookup finalChart j (Act cat lbl) + let found'' = found' ++ [(lbl, makeRange (j,k))] + recs' <- unifyRec recs nr found'' + return $ Active abs found i (Lin l syms) lins recs' + combine _ _ = [] + + complete2 k (Active abs found i (Lin l []) lins recs) = + do let found' = found ++ [(l, makeRange (i,k))] + (lin, lins') <- select lins + return $ Active abs found' k lin lins' recs + complete2 _ _ = [] + +---------------------------------------------------------------------- +-- type definitions + +type IChart c n l t = IncrementalChart (Item c n l t) (IKey c l t) + +data Item c n l t = Active (Abstract c n) + (RangeRec l) + Int + (Lin c l t) + (LinRec c l t) + [RangeRec l] + | Final (Abstract c n) (RangeRec l) [RangeRec l] + ---- | Passive c (RangeRec l) + deriving (Eq, Ord, Show) + +data IKey c l t = Act c l + | ActTok t + ---- | Useless + | Pass + | Fin + deriving (Eq, Ord, Show) + +keyof :: Item c n l t -> IKey c l t +keyof (Active _ _ _ (Lin _ (Cat (next,lbl,_):_)) _ _) = Act next lbl +keyof (Active _ _ _ (Lin _ (Tok tok:_)) _ _) = ActTok tok +keyof (Active _ _ _ (Lin _ []) _ _) = Pass +keyof (Final _ _ _) = Fin +-- keyof _ = Useless + + +---------------------------------------------------------------------- +-- for tracing purposes +prtSizes chart k = "f=" ++ show (length (chartLookup chart k Fin)) ++ + " p=" ++ show (length (chartLookup chart k Pass)) ++ + " a=" ++ show (sum [length (chartLookup chart k key) | + key@(Act _ _) <- chartKeys chart k ]) ++ + " t=" ++ show (sum [length (chartLookup chart k key) | + key@(ActTok _) <- chartKeys chart k ]) + -- " u=" ++ show (length (chartLookup chart k Useless)) + +-- prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ +-- prtBefore "\n " (chartLookup chart k) | +-- k <- chartKeys chart ] + +instance (Print c, Print n, Print l, Print t) => Print (Item c n l t) where + prt (Active abs found rng lin tofind children) = + "? " ++ prt abs ++ ";\n\t" ++ + "{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++ + prt lin ++ "{" ++ prtSep " " tofind ++ "}" ++ + ( if null children then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" ) + -- prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" + prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++ + ( if null rrs then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" ) + +instance (Print c, Print l, Print t) => Print (IKey c l t) where + prt (Act c l) = "Active " ++ prt c ++ " " ++ prt l + prt (ActTok t) = "ActiveTok " ++ prt t + -- prt (Pass c l i) = "Passive " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i + prt (Fin) = "Final" + -- prt (Useless) = "Useless" diff --git a/src-3.0/GF/Parsing/MCFG/Naive.hs b/src-3.0/GF/Parsing/MCFG/Naive.hs new file mode 100644 index 000000000..7d1fa0a8a --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/Naive.hs @@ -0,0 +1,142 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- MCFG parsing, the naive algorithm +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.Naive (parse, parseR) where + +import Control.Monad (guard) + +-- GF modules +import GF.Data.GeneralDeduction +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities +import GF.Parsing.MCFG.Range +import GF.Parsing.MCFG.PInfo +import GF.Data.SortedList +import GF.Data.Assoc +import GF.System.Tracing + +import GF.Infra.Print + +---------------------------------------------------------------------- +-- * parsing + +-- | Builds a chart from the initial agenda, given by prediction, and the inference rules +parse :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t +parse pinfo starts toks + = accumAssoc groupSyntaxNodes $ + [ ((cat, makeRangeRec lins), SNode fun (zip rhs rrecs)) | + Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ] + where chart = process pinfo toks + +-- | Builds a chart from the initial agenda, given by prediction, and the inference rules +-- parseR :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t +parseR pinfo starts + = accumAssoc groupSyntaxNodes $ + [ ((cat, makeRangeRec lins), SNode fun (zip rhs rrecs)) | + Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ] + where chart = processR pinfo + +process :: (Ord t, Ord n, Ord c, Ord l) => MCFPInfo c n l t -> Input t -> NChart c n l +process pinfo toks + = tracePrt "MCFG.Naive - chart size" prtSizes $ + buildChart keyof [convert, combine] (predict pinfo toks) + +processR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> NChart c n l +processR pinfo + = tracePrt "MCFG.Naive Range - chart size" prtSizes $ + buildChart keyof [convert, combine] (predictR pinfo) + + +---------------------------------------------------------------------- +-- * inference rules + +-- Creates an Active Item of every Rule in the Grammar to give the initial Agenda +predict :: (Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l] +predict pinfo toks = tracePrt "MCFG.Naive - predicted rules" (prt . length) $ + do Rule abs (Cnc _ _ lins) <- rulesMatchingInput pinfo toks + lins' <- rangeRestRec toks lins + return $ Active (abs, []) lins' [] + +-- Creates an Active Item of every Rule in the Grammar to give the initial Agenda +predictR :: (Ord l) => MCFPInfo c n l Range -> [Item c n l] +predictR pinfo = tracePrt "MCFG.Naive Range - predicted rules" (prt . length) $ + do Rule abs (Cnc _ _ lins) <- allRules pinfo + return $ Active (abs, []) lins [] + +-- | Creates an Active Item every time it is possible to combine +-- an Active Item from the agenda with a Passive Item from the Chart +combine :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l] +combine chart item@(Active (Abs _ (c:_) _, _) _ _) = + do Passive _c rrec <- chartLookup chart (Pass c) + combine2 chart rrec item +combine chart (Passive c rrec) = + do item <- chartLookup chart (Act c) + combine2 chart rrec item +combine _ _ = [] + +combine2 chart rrec (Active (Abs nt (c:find) f, found) lins rrecs) = + do lins' <- substArgRec (length found) rrec lins + return $ Active (Abs nt find f, found ++ [c]) lins' (rrecs ++ [rrec]) + +-- | Active Items with nothing to find are converted to Passive Items +convert :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l] +convert _ (Active (Abs cat [] fun, _) lins _) = [Passive cat (makeRangeRec lins)] +convert _ _ = [] + + +---------------------------------------------------------------------- +-- * type definitions + +type NChart c n l = ParseChart (Item c n l) (NKey c) + +data Item c n l = Active (DottedRule c n) (LinRec c l Range) [RangeRec l] + | Passive c (RangeRec l) + deriving (Eq, Ord, Show) + +type DottedRule c n = (Abstract c n, [c]) + +data NKey c = Act c + | Pass c + | Final + deriving (Eq, Ord, Show) + +keyof :: Item c n l -> NKey c +keyof (Active (Abs _ (next:_) _, _) _ _) = Act next +keyof (Passive cat _) = Pass cat +keyof _ = Final + +-- for tracing purposes +prtSizes chart = "final=" ++ show (length (chartLookup chart Final)) ++ + ", passive=" ++ show (sum [length (chartLookup chart k) | + k@(Pass _) <- chartKeys chart ]) ++ + ", active=" ++ show (sum [length (chartLookup chart k) | + k@(Act _) <- chartKeys chart ]) + +prtChart chart = concat [ "\n*** KEY: " ++ prt k ++ + prtBefore "\n " (chartLookup chart k) | + k <- chartKeys chart ] + +instance (Print c, Print n, Print l) => Print (Item c n l) where + prt (Active (abs, cs) lrec rrecs) = "? " ++ prt abs ++ " . " ++ prtSep " " cs ++ ";\n\t" ++ + "{" ++ prtSep " " lrec ++ "}" ++ + ( if null rrecs then ";" else ";\n\t" ++ + "{" ++ prtSep "} {" (map (prtSep " ") rrecs) ++ "}" ) + prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" + +instance Print c => Print (NKey c) where + prt (Act c) = "Active " ++ prt c + prt (Pass c) = "Passive " ++ prt c + prt (Final) = "Final" + + diff --git a/src-3.0/GF/Parsing/MCFG/PInfo.hs b/src-3.0/GF/Parsing/MCFG/PInfo.hs new file mode 100644 index 000000000..56119dcec --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/PInfo.hs @@ -0,0 +1,162 @@ +--------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/13 12:40:19 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- MCFG parsing, parser information +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.PInfo where + +import GF.System.Tracing +import GF.Infra.Print + +import GF.Formalism.Utilities +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Data.SortedList +import GF.Data.Assoc +import GF.Parsing.MCFG.Range + +---------------------------------------------------------------------- +-- type declarations + +-- | the list of categories = possible starting categories +type MCFParser c n l t = MCFPInfo c n l t + -> [c] + -> Input t + -> SyntaxChart n (c, RangeRec l) + +makeFinalEdge :: c -> l -> (Int, Int) -> (c, RangeRec l) +makeFinalEdge cat lbl bnds = (cat, [(lbl, makeRange bnds)]) + + +------------------------------------------------------------ +-- parser information + +data MCFPInfo c n l t + = MCFPInfo { grammarTokens :: SList t + , nameRules :: Assoc n (SList (MCFRule c n l t)) + , topdownRules :: Assoc c (SList (MCFRule c n l t)) + -- ^ used in 'GF.Parsing.MCFG.Active' (Earley): + , epsilonRules :: [MCFRule c n l t] + -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): + , leftcornerCats :: Assoc c (SList (MCFRule c n l t)) + , leftcornerTokens :: Assoc t (SList (MCFRule c n l t)) + -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): + , grammarCats :: SList c + -- ^ used when calculating starting categories + , rulesByToken :: Assoc t (SList (MCFRule c n l t, SList t)) + , rulesWithoutTokens :: SList (MCFRule c n l t) + -- ^ used by 'rulesMatchingInput' + , allRules :: MCFGrammar c n l t + -- ^ used by any unoptimized algorithm + + --bottomupRules :: Assoc (Symbol c t) (SList (CFRule c n t)), + --emptyLeftcornerRules :: Assoc c (SList (CFRule c n t)), + --emptyCategories :: Set c, + } + + +rangeRestrictPInfo :: (Ord c, Ord n, Ord l, Ord t) => + MCFPInfo c n l t -> Input t -> MCFPInfo c n l Range +rangeRestrictPInfo (pinfo{-::MCFPInfo c n l t-}) inp = + tracePrt "MCFG.PInfo - Restricting the parser information" (prt . grammarTokens) + MCFPInfo { grammarTokens = nubsort (map edgeRange (inputEdges inp)) + , nameRules = rrAssoc (nameRules pinfo) + , topdownRules = rrAssoc (topdownRules pinfo) + , epsilonRules = rrRules (epsilonRules pinfo) + , leftcornerCats = rrAssoc (leftcornerCats pinfo) + , leftcornerTokens = lctokens + , grammarCats = grammarCats pinfo + , rulesByToken = emptyAssoc -- error "MCFG.PInfo.rulesByToken - no range restriction" + , rulesWithoutTokens = [] -- error "MCFG.PInfo.rulesByToken - no range restriction" + , allRules = allrules -- rrRules (allRules pinfo) + } + + where lctokens = accumAssoc id + [ (rng, rule) | (tok, rules) <- aAssocs (leftcornerTokens pinfo), + inputToken inp ?= tok, + rule@(Rule _ (Cnc _ _ (Lin _ (Tok rng:_) : _))) + <- concatMap (rangeRestrictRule inp) rules ] + + allrules = rrRules $ rulesMatchingInput pinfo inp + + rrAssoc assoc = filterNull $ fmap rrRules assoc + filterNull assoc = assocFilter (not . null) assoc + rrRules rules = concatMap (rangeRestrictRule inp) rules + + +buildMCFPInfo :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> MCFPInfo c n l t +buildMCFPInfo grammar = + traceCalcFirst grammar $ + tracePrt "MCFG.PInfo - parser info" (prt) $ + MCFPInfo { grammarTokens = grammartokens + , nameRules = namerules + , topdownRules = topdownrules + , epsilonRules = epsilonrules + , leftcornerCats = leftcorncats + , leftcornerTokens = leftcorntoks + , grammarCats = grammarcats + , rulesByToken = rulesbytoken + , rulesWithoutTokens = ruleswithouttokens + , allRules = allrules + } + + where allrules = concatMap expandVariants grammar + grammartokens = union (map fst ruletokens) + namerules = accumAssoc id + [ (name, rule) | rule@(Rule (Abs _ _ name) _) <- allrules ] + topdownrules = accumAssoc id + [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- allrules ] + epsilonrules = [ rule | rule@(Rule _ (Cnc _ _ (Lin _ [] : _))) <- allrules ] + leftcorncats = accumAssoc id + [ (cat, rule) | + rule@(Rule _ (Cnc _ _ (Lin _ (Cat(cat,_,_):_) : _))) <- allrules ] + leftcorntoks = accumAssoc id + [ (tok, rule) | + rule@(Rule _ (Cnc _ _ (Lin _ (Tok tok:_) : _))) <- allrules ] + grammarcats = aElems topdownrules + ruletokens = [ (toksoflins lins, rule) | + rule@(Rule _ (Cnc _ _ lins)) <- allrules ] + toksoflins lins = nubsort [ tok | Lin _ syms <- lins, Tok tok <- syms ] + rulesbytoken = accumAssoc id + [ (tok, (rule, toks)) | (tok:toks, rule) <- ruletokens ] + ruleswithouttokens = nubsort [ rule | ([], rule) <- ruletokens ] + + +-- | return only the rules for which all tokens are in the input string +rulesMatchingInput :: Ord t => MCFPInfo c n l t -> Input t -> [MCFRule c n l t] +rulesMatchingInput pinfo inp = + [ rule | tok <- toks, + (rule, ruletoks) <- rulesByToken pinfo ? tok, + ruletoks `subset` toks ] + ++ rulesWithoutTokens pinfo + where toks = aElems (inputToken inp) + + +---------------------------------------------------------------------- +-- pretty-printing of statistics + +instance (Ord c, Ord n, Ord l, Ord t) => Print (MCFPInfo c n l t) where + prt pI = "[ tokens=" ++ sl grammarTokens ++ + "; categories=" ++ sl grammarCats ++ + "; nameRules=" ++ sla nameRules ++ + "; tdRules=" ++ sla topdownRules ++ + "; epsilonRules=" ++ sl epsilonRules ++ + "; lcCats=" ++ sla leftcornerCats ++ + "; lcTokens=" ++ sla leftcornerTokens ++ + "; byToken=" ++ sla rulesByToken ++ + "; noTokens=" ++ sl rulesWithoutTokens ++ + "; allRules=" ++ sl allRules ++ + " ]" + + where sl f = show $ length $ f pI + sla f = let (as, bs) = unzip $ aAssocs $ f pI + in show (length as) ++ "/" ++ show (length (concat bs)) + diff --git a/src-3.0/GF/Parsing/MCFG/Range.hs b/src-3.0/GF/Parsing/MCFG/Range.hs new file mode 100644 index 000000000..91671fa00 --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/Range.hs @@ -0,0 +1,206 @@ +--------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.5 $ +-- +-- Definitions of ranges, and operations on ranges +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.Range + ( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange, + LinRec, RangeRec, + makeRangeRec, rangeRestRec, rangeRestrictRule, + projection, unifyRec, substArgRec + ) where + + +-- Haskell +import Data.List +import Control.Monad + +-- GF modules +import GF.Formalism.GCFG +import GF.Formalism.MCFG +import GF.Formalism.Utilities +import GF.Infra.Print +import GF.Data.Assoc ((?)) +import GF.Data.Utilities (updateNthM) + +------------------------------------------------------------ +-- ranges as single pairs + +data Range = Range (Int, Int) + | EmptyRange + deriving (Eq, Ord, Show) + +makeRange :: (Int, Int) -> Range +concatRange :: Range -> Range -> [Range] +rangeEdge :: a -> Range -> Edge a +edgeRange :: Edge a -> Range +minRange :: Range -> Int +maxRange :: Range -> Int + +makeRange = Range +concatRange EmptyRange rng = return rng +concatRange rng EmptyRange = return rng +concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j'] +rangeEdge a (Range(i,j)) = Edge i j a +edgeRange (Edge i j _) = Range (i,j) +minRange (Range rho) = fst rho +maxRange (Range rho) = snd rho + +instance Print Range where + prt (Range (i,j)) = "(" ++ show i ++ "-" ++ show j ++ ")" + prt (EmptyRange) = "(?)" + +{-- Types -------------------------------------------------------------------- + Linearization- and Range records implemented as lists +-----------------------------------------------------------------------------} + +type LinRec c l t = [Lin c l t] + +type RangeRec l = [(l, Range)] + + +{-- Functions ---------------------------------------------------------------- + Concatenation : Concatenation of Ranges, Symbols and Linearizations + and records of Linearizations + Record transformation : Makes a Range record from a fully instantiated + Linearization record + Record projection : Given a label, returns the corresponding Range + Range restriction : Range restriction of Tokens, Symbols, + Linearizations and Records given a list of Tokens + Record replacment : Substitute a record for another in a list of Range + records + Argument substitution : Substitution of a Cat c to a Tok Range, where + Range is the cover of c + Note: The argument is still a Symbol c Range + Subsumation : Checks if a Range record subsumes another Range + record + Record unification : Unification of two Range records +-----------------------------------------------------------------------------} + + +--- Concatenation ------------------------------------------------------------ + + +concSymbols :: [Symbol c Range] -> [[Symbol c Range]] +concSymbols (Tok rng:Tok rng':toks) = do rng'' <- concatRange rng rng' + concSymbols (Tok rng'':toks) +concSymbols (sym:syms) = do syms' <- concSymbols syms + return (sym:syms') +concSymbols [] = return [] + + +concLin :: Lin c l Range -> [Lin c l Range] +concLin (Lin lbl syms) = do syms' <- concSymbols syms + return (Lin lbl syms') + + +concLinRec :: LinRec c l Range -> [LinRec c l Range] +concLinRec = mapM concLin + + +--- Record transformation ---------------------------------------------------- + +makeRangeRec :: LinRec c l Range -> RangeRec l +makeRangeRec lins = map convLin lins + where convLin (Lin lbl [Tok rng]) = (lbl, rng) + convLin (Lin lbl []) = (lbl, EmptyRange) + convLin _ = error "makeRangeRec" + + +--- Record projection -------------------------------------------------------- + +projection :: Ord l => l -> RangeRec l -> [Range] +projection l rec = maybe (fail "projection") return $ lookup l rec + + +--- Range restriction -------------------------------------------------------- + +rangeRestTok :: Ord t => Input t -> t -> [Range] +rangeRestTok toks tok = do rng <- inputToken toks ? tok + return (makeRange rng) + + +rangeRestSym :: Ord t => Input t -> Symbol a t -> [Symbol a Range] +rangeRestSym toks (Tok tok) = do rng <- rangeRestTok toks tok + return (Tok rng) +rangeRestSym _ (Cat c) = return (Cat c) + + +rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range] +rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms + concLin (Lin lbl syms') + -- return (Lin lbl syms') + + +rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range] +rangeRestRec toks = mapM (rangeRestLin toks) + + +rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range] +rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $ + rangeRestRec toks lins + +--- Argument substitution ---------------------------------------------------- + +substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range + -> Symbol (c, l, Int) Range +substArgSymbol i rec tok@(Tok rng) = tok +substArgSymbol i rec cat@(Cat (c, l, j)) + | i==j = maybe err Tok $ lookup l rec + | otherwise = cat + where err = error "substArg: Label not in range-record" + +substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range + -> [Lin c l Range] +substArgLin i rec (Lin lbl syms) = + concLin (Lin lbl (map (substArgSymbol i rec) syms)) + + +substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range + -> [LinRec c l Range] +substArgRec i rec lins = mapM (substArgLin i rec) lins + + +-- Record unification & replacment --------------------------------------------------------- + +unifyRec :: Ord l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]] +unifyRec recs i rec = updateNthM update i recs + where update rec' = guard (subsumes rec' rec) >> return rec + +-- unifyRec recs i rec = do guard $ subsumes (recs !! i) rec +-- return $ replaceRec recs i rec + +replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l] +replaceRec recs i rec = before ++ (rec : after) + where (before, _ : after) = splitAt i recs + +subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool +subsumes rec rec' = and [r `elem` rec' | r <- rec] +-- subsumes rec rec' = all (`elem` rec') rec + + +{- +--- Record unification ------------------------------------------------------- +unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]] +unifyRangeRecs recs recs' = zipWithM unify recs recs' + where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l] + unify rec [] = return rec + unify [] rec = return rec + unify rec1'@(p1@(l1, r1):rec1) rec2'@(p2@(l2, r2):rec2) + = case compare l1 l2 of + LT -> do rec3 <- unify rec1 rec2' + return (p1:rec3) + GT -> do rec3 <- unify rec1' rec2 + return (p2:rec3) + EQ -> do guard (r1 == r2) + rec3 <- unify rec1 rec2 + return (p1:rec3) +-} diff --git a/src-3.0/GF/Parsing/MCFG/ViaCFG.hs b/src-3.0/GF/Parsing/MCFG/ViaCFG.hs new file mode 100644 index 000000000..9204ea9f1 --- /dev/null +++ b/src-3.0/GF/Parsing/MCFG/ViaCFG.hs @@ -0,0 +1,186 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.4 $ +-- +-- MCFG parsing, through context-free approximation +----------------------------------------------------------------------------- + +module GF.Parsing.MCFG.ViaCFG where + + +-- Haskell modules +import Data.List +import Control.Monad + +-- GF modules +import ConvertMCFGtoDecoratedCFG +import qualified DecoratedCFParser as CFP +import qualified DecoratedGrammar as CFG +import Examples +import GF.OldParsing.GeneralChart +import qualified GF.OldParsing.MCFGrammar as MCFG +import MCFParser +import Nondet +import Parser +import GF.Parsing.MCFG.Range + + +{-- Datatypes ----------------------------------------------------------------- +Chart +Item +Key + + + Item : Four different Items are used. PreMCFG for MCFG Pre Items, Pre are + the Items returned by the pre-Functions and Mark are the + corresponding Items for the mark-Functions. For convenience correctly + marked Mark Items are converted to Passive Items. +I use dottedrule for convenience to keep track of wich daughter's RangeRec to look for. + AChart: A RedBlackMap with Items and Keys + AKey : +------------------------------------------------------------------------------} + +--Ev ta bort några typer av Item och bara nyckla på det som är unikt för den typen... +data Item n c l = PreMCFG (n, c) (RangeRec l) [RangeRec l] + | Pre (n, c) (RangeRec l) [l] [RangeRec l] + | Mark (n, c) (RangeRec l) (RangeRec l) [RangeRec l] + | Passive (n, c) (RangeRec l) (RangeRec l) + deriving (Eq, Ord, Show) + +type AChart n c l = ParseChart (Item n c l) (AKey n c l) + +data AKey n c l = Pr (n, c) l + | Pm (n, c) l + | Mk (RangeRec l) + | Ps (RangeRec l) + | Useless + deriving (Eq, Ord, Show) + + +{-- Parsing ------------------------------------------------------------------- + recognize: + parse : The Agenda consists of the Passive Items from context-free + approximation (as PreMCFG Items) and the Pre Items inferred by + pre-prediction. + keyof : Given an Item returns an appropriate Key for the Chart +------------------------------------------------------------------------------} + +recognize strategy mcfg toks = chartMember (parse strategy mcfg toks) + (Passive ("f", S) + [("s" , MCFG.Range (0, n))] + [("p" , MCFG.Range (0, n2)), ("q", MCFG.Range (n2, n))]) + (Ps [("s" , MCFG.Range (0, n))]) + where n = length toks + n2 = n `div` 2 + + +--parse :: (Ord n, Ord NT, Ord String, Eq t) => CFP.Strategy -> MCFG.Grammar n NT String t -> [t] +-- -> AChart n NT String +parse strategy mcfg toks + = buildChart keyof + [preCombine, markPredict, markCombine, convert] + (makePreItems (CFP.parse strategy (CFG.pInfo (convertGrammar mcfg)) [(S, "s")] toks) ++ + (prePredict mcfg)) + + +keyof :: Item n c l -> AKey n c l +keyof (PreMCFG head [(lbl, rng)] _) = Pm head lbl +keyof (Pre head _ (lbl:lbls) _) = Pr head lbl +keyof (Mark _ _ _ (rec:recs)) = Mk rec +keyof (Passive _ rec _) = Ps rec +keyof _ = Useless + + +{-- Initializing agenda ------------------------------------------------------- + makePreItems: +------------------------------------------------------------------------------} + +makePreItems :: (Eq c, Ord i) => CFG.Grammar n (Edge (c, l)) i t -> [Item n c l] +makePreItems cfchart + = [ PreMCFG (fun, cat) [(lbl, MCFG.makeRange (i, j))] (symToRec beta) | + CFG.Rule (Edge i j (cat,lbl)) beta fun <- cfchart ] + + +prePredict :: (Ord n, Ord c, Ord l) => MCFG.Grammar n c l t -> [Item n c l] +prePredict mcfg = + [ Pre (f, nt) [] (getLables lins) (replicate (nrOfCats (head lins)) []) | + MCFG.Rule nt nts lins f <- mcfg ] + + +{-- Inference rules --------------------------------------------------------- + prePredict : + preCombine : + markPredict: + markCombine: + convert : +----------------------------------------------------------------------------} + +preCombine :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) + -> Item n c l -> [Item n c l] +preCombine chart (Pre head rec (l:ls) recs) = + [ Pre head (rec ++ [(l, r)]) ls recs'' | + PreMCFG head [(l, r)] recs' <- chartLookup chart (Pm head l), + recs'' <- solutions (unifyRangeRecs recs recs') ] +preCombine chart (PreMCFG head [(l, r)] recs) = + [ Pre head (rec ++ [(l, r)]) ls recs'' | + Pre head rec (l:ls) recs' <- chartLookup chart (Pr head l), + recs'' <- solutions (unifyRangeRecs recs recs') ] +preCombine _ _ = [] + + +markPredict :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) + -> Item n c l -> [Item n c l] +markPredict _ (Pre (n, c) rec [] recs) = [Mark (n, c) rec [] recs] +markPredict _ _ = [] + + +markCombine :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) + -> Item n c l -> [Item n c l] +markCombine chart (Mark (f, c) rec mRec (r:recs)) = + [ Mark (f, c) rec (mRec ++ r) recs | + Passive _ r _ <- chartLookup chart (Ps r)] +markCombine chart (Passive _ r _) = + [ Mark (f, c) rec (mRec++r) recs | + Mark (f, c) rec mRec (r:recs) <- chartLookup chart (Mk r) ] +markCombine _ _ = [] + + +convert :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) + -> Item n c l -> [Item n c l] +convert _ (Mark (f, c) r rec []) = [Passive (f, c) r rec] +convert _ _ = [] + + +{-- Help functions ---------------------------------------------------------------- + getRHS : + getLables: + symToRec : +----------------------------------------------------------------------------------} + +-- FULKOD ! +nrOfCats :: Eq c => MCFG.Lin c l t -> Int +nrOfCats (MCFG.Lin l syms) = length $ nub [(c, i) | Cat (c, l, i) <- syms] + + +-- +getLables :: LinRec c l t -> [l] +getLables lins = [l | MCFG.Lin l syms <- lins] + + +-- +symToRec :: Ord i => [Symbol (Edge (c, l), i) d] -> [[(l, MCFG.Range)]] +symToRec beta = map makeLblRng $ groupBy (\(_, d) (_, d') -> (d == d')) + $ sortBy sBd [(Edge i j (c, l) , d) | Cat (Edge i j (c, l), d) + <- beta] + where makeLblRng edges = [(l, (MCFG.makeRange (i, j))) | (Edge i j (_, l), _) + <- edges] + sBd (_, d) (_, d') + | d < d' = LT + | d > d' = GT + | otherwise = EQ diff --git a/src-3.0/GF/Printing/PrintParser.hs b/src-3.0/GF/Printing/PrintParser.hs new file mode 100644 index 000000000..d9041ecaa --- /dev/null +++ b/src-3.0/GF/Printing/PrintParser.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrintParser +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:16 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Pretty-printing of parser objects +----------------------------------------------------------------------------- + +module GF.Printing.PrintParser (Print(..), + prtBefore, prtAfter, prtSep, + prtBeforeAfter, + prIO + ) where + +-- haskell modules: +import Data.List (intersperse) +-- gf modules: +import GF.Data.Operations (Err(..)) +import GF.Infra.Ident (Ident(..)) +import qualified GF.Canon.PrintGFC as P + +------------------------------------------------------------ + +prtBefore :: Print a => String -> [a] -> String +prtBefore before = prtBeforeAfter before "" + +prtAfter :: Print a => String -> [a] -> String +prtAfter after = prtBeforeAfter "" after + +prtSep :: Print a => String -> [a] -> String +prtSep sep = concat . intersperse sep . map prt + +prtBeforeAfter :: Print a => String -> String -> [a] -> String +prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ] + +prIO :: Print a => a -> IO () +prIO = putStr . prt + +class Print a where + prt :: a -> String + prtList :: [a] -> String + prtList as = "[" ++ prtSep "," as ++ "]" + +instance Print a => Print [a] where + prt = prtList + +instance (Print a, Print b) => Print (a, b) where + prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")" + +instance (Print a, Print b, Print c) => Print (a, b, c) where + prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")" + +instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where + prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")" + +instance Print Char where + prt = return + prtList = id + +instance Print Int where + prt = show + +instance Print Integer where + prt = show + +instance Print a => Print (Maybe a) where + prt (Just a) = "!" ++ prt a + prt Nothing = "Nothing" + +instance Print a => Print (Err a) where + prt (Ok a) = prt a + prt (Bad str) = str + +instance Print Ident where + prt ident = str + where str = P.printTree ident + diff --git a/src-3.0/GF/Printing/PrintSimplifiedTerm.hs b/src-3.0/GF/Printing/PrintSimplifiedTerm.hs new file mode 100644 index 000000000..ccd107558 --- /dev/null +++ b/src-3.0/GF/Printing/PrintSimplifiedTerm.hs @@ -0,0 +1,127 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrintSimplifiedTerm +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 14:15:19 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.4 $ +-- +-- Instances for printing terms in a simplified format +----------------------------------------------------------------------------- + + +module GF.Printing.PrintSimplifiedTerm () where + +import GF.Canon.AbsGFC +import GF.CF.CF +import GF.CF.CFIdent +import GF.Printing.PrintParser +import qualified GF.Canon.PrintGFC as P + +instance Print Term where + prt (Arg arg) = prt arg + prt (con `Par` []) = prt con + prt (con `Par` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")" + prt (LI ident) = prt ident + prt (R record) = "{" ++ prtSep ";" record ++ "}" + prt (term `P` lbl) = prt term ++ "." ++ prt lbl + prt (T _ table) = "table{" ++ prtSep ";" table ++ "}" + prt (term `S` sel) = prt term ++ "!" ++ prt sel + prt (FV terms) = "variants{" ++ prtSep "|" terms ++ "}" + prt (term `C` term') = prt term ++ " " ++ prt term' + prt (K tokn) = show (prt tokn) + prt (E) = show "" + +instance Print Patt where + prt (con `PC` []) = prt con + prt (con `PC` pats) = prt con ++ "(" ++ prtSep "," pats ++ ")" + prt (PV ident) = prt ident + prt (PW) = "_" + prt (PR record) = "{" ++ prtSep ";" record ++ "}" + +instance Print Label where + prt (L ident) = prt ident + prt (LV nr) = "$" ++ show nr + +instance Print Tokn where + prt (KS str) = str + prt tokn@(KP _ _) = show tokn + +instance Print ArgVar where + prt (A cat argNr) = prt cat ++ "#" ++ show argNr + +instance Print CIdent where + prt (CIQ _ ident) = prt ident + +instance Print Case where + prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term + +instance Print Assign where + prt (lbl `Ass` term) = prt lbl ++ "=" ++ prt term + +instance Print PattAssign where + prt (lbl `PAss` pat) = prt lbl ++ "=" ++ prt pat + +instance Print Atom where + prt (AC c) = prt c + prt (AD c) = "<" ++ prt c ++ ">" + prt (AV i) = "$" ++ prt i + prt (AM n) = "?" ++ show n + prt (AS s) = show s + prt (AI n) = show n + prt (AT s) = show s + +instance Print CType where + prt (RecType rtype) = "{" ++ prtSep ";" rtype ++ "}" + prt (Table ptype vtype) = "(" ++ prt ptype ++ "=>" ++ prt vtype ++ ")" + prt (Cn cn) = prt cn + prt (TStr) = "Str" + +instance Print Labelling where + prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype + +instance Print CFItem where + prt (CFTerm regexp) = prt regexp + prt (CFNonterm cat) = prt cat + +instance Print RegExp where + prt (RegAlts words) = "("++prtSep "|" words ++ ")" + prt (RegSpec tok) = prt tok + +instance Print CFTok where + prt (TS str) = str + prt tok = show tok + +instance Print CFCat where + prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl + +instance Print CFFun where + prt (CFFun fun) = prt (fst fun) + +instance Print Exp where + prt = P.printTree + + +sizeCT :: CType -> Int +sizeCT (RecType rt) = 1 + sum [ sizeCT t | _ `Lbg` t <- rt ] +sizeCT (Table pt vt) = 1 + sizeCT pt + sizeCT vt +sizeCT (Cn cn) = 1 +sizeCT (TStr) = 1 + +sizeT :: Term -> Int +sizeT (_ `Par` ts) = 2 + sum (map sizeT ts) +sizeT (R rec) = 1 + sum [ sizeT t | _ `Ass` t <- rec ] +sizeT (t `P` _) = 1 + sizeT t +sizeT (T _ tbl) = 1 + sum [ sum (map sizeP ps) + sizeT t | ps `Cas` t <- tbl ] +sizeT (t `S` s) = 1 + sizeT t + sizeT s +sizeT (t `C` t') = 1 + sizeT t + sizeT t' +sizeT (FV ts) = 1 + sum (map sizeT ts) +sizeT _ = 1 + +sizeP :: Patt -> Int +sizeP (con `PC` pats) = 2 + sum (map sizeP pats) +sizeP (PR record) = 1 + sum [ sizeP p | _ `PAss` p <- record ] +sizeP _ = 1 diff --git a/src-3.0/GF/Probabilistic/Probabilistic.hs b/src-3.0/GF/Probabilistic/Probabilistic.hs new file mode 100644 index 000000000..25258db52 --- /dev/null +++ b/src-3.0/GF/Probabilistic/Probabilistic.hs @@ -0,0 +1,203 @@ +---------------------------------------------------------------------- +-- | +-- Module : Probabilistic +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/01 09:20:09 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.5 $ +-- +-- Probabilistic abstract syntax. AR 30\/10\/2005 +-- +-- (c) Aarne Ranta 2005 under GNU GPL +-- +-- Contents: parsing and random generation with probabilistic grammars. +-- To begin with, we use simple types and don't +-- guarantee the correctness of bindings\/dependences. +----------------------------------------------------------------------------- + +module GF.Probabilistic.Probabilistic ( + generateRandomTreesProb -- :: Options -> StdGen -> GFCGrammar -> Probs -> Cat -> [Exp] + ,checkGrammarProbs -- :: GFCGrammar -> Probs -> Err () + ,computeProbTree -- :: Probs -> Tree -> Double + ,rankByScore -- :: Ord n => [(a,n)] -> [(a,n)] + ,Probs -- = BinTree Ident Double + ,getProbsFromFile -- :: Opts -> IO Probs + ,emptyProbs -- :: Probs + ,prProbs -- :: Probs -> String + ) where + +import GF.Canon.GFC +import GF.Grammar.LookAbs +import GF.Grammar.PrGrammar +import GF.Grammar.Macros +import GF.Grammar.Values +import GF.Grammar.Grammar +import GF.Grammar.SGrammar + +import GF.Infra.Ident +import GF.Data.Zipper +import GF.Data.Operations +import GF.Infra.Option + +import Data.Char +import Data.List +import Control.Monad +import System.Random + +-- | this parameter tells how many constructors at most are generated in a tree +timeout :: Int +timeout = 99 + +-- | generate an infinite list of trees, with their probabilities +generateRandomTreesProb :: Options -> StdGen -> GFCGrammar -> Probs -> Cat -> [Exp] +generateRandomTreesProb opts gen gr probs cat = + map str2tr $ randomTrees gen gr' cat' where + gr' = gr2sgr opts probs gr + cat' = prt $ snd cat + +-- | check that probabilities attached to a grammar make sense +checkGrammarProbs :: GFCGrammar -> Probs -> Err Probs +checkGrammarProbs gr probs = + err Bad (return . gr2probs) $ checkSGrammar $ gr2sgr noOptions probs gr where + gr2probs sgr = buildTree [(zIdent f,p) | (_,rs) <- tree2list sgr, ((p,f),_) <- rs] + +-- | compute the probability of a given tree +computeProbTree :: Probs -> Tree -> Double +computeProbTree probs (Tr (N (_,at,_,_,_),ts)) = case at of + AtC (_,f) -> case lookupTree prt f probs of + Ok p -> p * product (map prob ts) + _ -> product (map prob ts) + _ -> 1.0 ---- + where + prob = computeProbTree probs + +-- | rank from highest to lowest score, e.g. probability +rankByScore :: Ord n => [(a,n)] -> [(a,n)] +rankByScore = sortBy (\ (_,p) (_,q) -> compare q p) + +getProbsFromFile :: Options -> FilePath -> IO Probs +getProbsFromFile opts file = do + s <- maybe (readFile file) readFile $ getOptVal opts probFile + return $ buildTree $ concatMap pProb $ lines s +-- where +pProb s = case words s of + "--#":"prob":f:p:_ | isDouble p -> [(zIdent f, read p)] + f:ps@(g:rest) -> case span (/= "--#") ps of + (_,_:"prob":p:_) | isDouble p -> [(zIdent f', readD p)] where + f' = if elem f ["fun","lin","data"] then ident g else ident f + _ -> [] + _ -> [] + where + isDouble = all (flip elem ('.':['0'..'9'])) + ident = takeWhile (flip notElem ".:") + readD :: String -> Double + readD = read + +------------------------------------------ +-- translate grammar to simpler form and generated trees back + +probTree :: STree -> Double +probTree t = case t of + SApp ((p,_),ts) -> p * product (map probTree ts) + _ -> 1 + +rankTrees :: [STree] -> [(STree,Double)] +rankTrees ts = sortBy (\ (_,p) (_,q) -> compare q p) [(t,probTree t) | t <- ts] + +randomTrees :: StdGen -> SGrammar -> SCat -> [STree] +randomTrees gen = genTrees (randomRs (0.0, 1.0) gen) + +genTrees :: [Double] -> SGrammar -> SCat -> [STree] +genTrees ds0 gr cat = + let (ds,ds2) = splitAt (timeout+1) ds0 -- for time out, else ds + (t,k) = genTree ds gr cat + in (if k>timeout then id else (t:)) -- don't accept with metas + (genTrees ds2 gr cat) -- else (drop k ds) + +genTree :: [Double] -> SGrammar -> SCat -> (STree,Int) +genTree rs gr = gett rs where + gett [] cat = (SMeta cat,1) -- time-out case + gett ds "String" = (SString "foo",1) + gett ds "Int" = (SInt 1978,1) + gett ds "Float" = (SFloat 3.1415926, 1) + gett ds cat = case look cat of + [] -> (SMeta cat,1) -- if no productions, return ? + fs -> let + d:ds2 = ds + (pf,args) = getf d fs + (ts,k) = getts ds2 args + in (SApp (pf,ts), k+1) + getf d fs = hitRegion d [(p,(pf,args)) | (pf@(p,_),(args,_)) <- fs] + getts ds cats = case cats of + c:cs -> let + (t, k) = gett ds c + (ts,ks) = getts (drop k ds) cs + in (t:ts, k + ks) + _ -> ([],0) + look cat = errVal [] $ lookupTree id cat gr + +hitRegion :: Double -> [(Double,a)] -> a +hitRegion d vs = case vs of + (p1,v1):vs2 -> + if d < p1 then v1 else hitRegion d [(p+p1,v) | (p,v) <- vs2] + +--- this should recover from rounding errors + +checkSGrammar :: SGrammar -> Err SGrammar +checkSGrammar = mapMTree chCat where + chCat (c,rs) = case sum [p | ((p,f),_) <- rs] of + s | abs (s - 1.0) > 0.01 -> + Bad $ "illegal probability sum " ++ show s ++ " in " ++ c + _ -> return (c,rs) + + +{- +------------------------------------------ +-- to test outside GF + +prSTree t = case t of + SApp ((p,f),ts) -> f ++ prParenth (show p) ++ concat (map pr1 ts) + SMeta c -> '?':c + SString s -> prQuotedString s + SInt i -> show i + SFloat i -> show i + where + pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t) + pr1 t = prSTree t + + +mkSGrammar :: [SRule] -> SGrammar +mkSGrammar rules = + buildTree [(c, fillProb rs) | rs@((_,(_,c)):_) <- rules'] where + rules' = + groupBy (\x y -> scat x == scat y) $ + sortBy (\x y -> compare (scat x) (scat y)) + rules + scat (_,(_,c)) = c + +pSRule :: String -> SRule +pSRule s = case words s of + p : f : c : cs -> + if isDigit (head p) + then ((read p, f),(init cs', last cs')) + else ((2.0, p),(init (c:cs'), last (c:cs'))) --- hack for automatic probability + where cs' = [cs !! i | i <- [0,2..length cs - 1]] + _ -> error $ "not a rule" +++ s + +expSgr = mkSGrammar $ map pSRule [ + "0.8 a : A" + ,"0.2 b : A" + ,"0.2 n : A -> S -> S" + ,"0.8 e : S" + ] + +ex1 :: IO () +ex1 = do + g <- newStdGen + mapM_ (putStrLn . prSTree) $ randomTrees g exSgr "S" + +-} + diff --git a/src-3.0/GF/Shell.hs b/src-3.0/GF/Shell.hs new file mode 100644 index 000000000..1d723bc62 --- /dev/null +++ b/src-3.0/GF/Shell.hs @@ -0,0 +1,591 @@ +---------------------------------------------------------------------- +-- | +-- Module : Shell +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/07 20:15:05 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.50 $ +-- +-- GF shell command interpreter. +----------------------------------------------------------------------------- + +module GF.Shell where + +--- abstract away from these? +import GF.Data.Str +import qualified GF.Grammar.Grammar as G +import qualified GF.Infra.Ident as I +import qualified GF.Grammar.Compute as Co +import qualified GF.Compile.CheckGrammar as Ch +import qualified GF.Grammar.Lookup as L +import qualified GF.Canon.GFC as GFC +import qualified GF.Canon.Look as Look +import qualified GF.Canon.CMacros as CMacros +import qualified GF.Grammar.MMacros as MMacros +import qualified GF.Compile.GrammarToCanon as GrammarToCanon +import GF.Grammar.Values +import GF.UseGrammar.GetTree +import GF.UseGrammar.Generate (generateAll) ---- should be in API +import GF.UseGrammar.Treebank +import GF.UseGrammar.TreeSelections (getOverloadResults) + +import GF.Shell.ShellCommands + +import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSourceGrammar) +import GF.Visualization.VisualizeTree (visualizeTrees) +import GF.API +import GF.API.IOGrammar +import GF.Compile.Compile +---- import GFTex +import GF.Shell.TeachYourself -- also a subshell + +import GF.UseGrammar.Randomized --- +import GF.UseGrammar.Editing (goFirstMeta) --- + +import GF.Probabilistic.Probabilistic + +import GF.Compile.ShellState +import GF.Infra.Option +import GF.UseGrammar.Information +import GF.Shell.HelpFile +import GF.Compile.PrOld +import GF.Compile.Wordlist +import GF.Grammar.PrGrammar + +import Control.Monad (foldM,liftM) +import System (system) +import System.IO (hPutStrLn, stderr) +import System.Random (newStdGen) ---- +import Data.List (nub,isPrefixOf) +import GF.Data.Zipper ---- + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Text.UTF8 (encodeUTF8) +import Data.Char (isDigit) +import Data.Maybe (fromMaybe) + +import GF.System.Signal (runInterruptibly) +import System.Exit (exitFailure) +import System.FilePath + +---- import qualified GrammarToGramlet as Gr +---- import qualified GrammarToCanonXML2 as Canon + +-- AR 18/4/2000 - 7/11/2001 + +-- data Command moved to ShellCommands. AR 27/5/2004 + +type CommandLine = (CommandOpt, CommandArg, [CommandOpt]) + +-- | term as returned by the command parser +type SrcTerm = G.Term + +-- | history & CPU +type HState = (ShellState,([String],Integer,ShMacros,ShTerms)) + +type ShMacros = [(String,[String])] -- dc %c = ... #1 ... #2 ... +type ShTerms = [(String,Tree)] -- dt $e = f ... + +type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg) + +initHState :: ShellState -> HState +initHState st = (st,([],0,[],[])) + +cpuHState :: HState -> Integer +cpuHState (_,(_,i,_,_)) = i + +optsHState :: HState -> Options +optsHState (st,_) = globalOptions st + +putHStateCPU :: Integer -> HState -> HState +putHStateCPU cpu (st,(h,_,c,t)) = (st,(h,cpu,c,t)) + +updateHistory :: String -> HState -> HState +updateHistory s (st,(h,cpu,c,t)) = (st,(s:h,cpu,c,t)) + +addShMacro :: (String,[String]) -> HState -> HState +addShMacro m (st,(h,cpu,c,t)) = (st,(h,cpu,m:c,t)) + +addShTerm :: (String,Tree) -> HState -> HState +addShTerm m (st,(h,cpu,c,t)) = (st,(h,cpu,c,m:t)) + +resolveShMacro :: HState -> String -> [String] -> [String] +resolveShMacro st@(_,(_,_,cs,_)) c args = case lookup c cs of + Just def -> map subst def + _ -> [] ---- + where + subst s = case s of + "#1" -> unwords args + _ -> s + --- so far only one arg allowed - how to determine arg boundaries? +{- + subst s = case s of + '#':d@(_:_) | all isDigit d -> + let i = read d in if i > lg then s else args !! (i-1) -- #1 is first + _ -> s + lg = length args +-} + +lookupShTerm :: HState -> String -> Maybe Tree +lookupShTerm st@(_,(_,_,_,ts)) c = lookup c ts + +txtHelpMacros :: HState -> String +txtHelpMacros (_,(_,_,cs,ts)) = unlines $ + ["Defined commands:",""] ++ + [c +++ "=" +++ unwords def | (c,def) <- cs] ++ + ["","Defined terms:",""] ++ + [c +++ "=" +++ prt_ def | (c,def) <- ts] + +-- | empty command if index over +earlierCommandH :: HState -> Int -> String +earlierCommandH (_,(h,_,_,_)) = ((h ++ repeat "") !!) + +execLinesH :: String -> [CommandLine] -> HState -> IO HState +execLinesH s cs hst@(st, (h,_,_,_)) = do + (_,st') <- execLinesI True cs hst + cpu <- prOptCPU (optsHState st') (cpuHState hst) + return $ putHStateCPU cpu $ updateHistory s st' + +-- | Like 'execLines', but can be interrupted by SIGINT. +execLinesI :: Bool -> [CommandLine] -> HState -> IO ([String],HState) +execLinesI put cs st = + do + x <- runInterruptibly (execLines put cs st) + case x of + Left ex -> do hPutStrLn stderr "" + hPutStrLn stderr $ show ex + return ([],st) + Right y -> return y + +ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options) +ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls] + +-- | the main function: execution of commands. 'put :: Bool' forces immediate output +-- +-- command line with consecutive (;) commands: no value transmitted +execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState) +execLines put cs st = foldM (flip (execLine put)) ([],st) cs + +-- | command line with piped (|) commands: no value returned +execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState) +execLine put (c@(co, os), arg, cs) (outps,st) = do + (st',val) <- execC c (st, arg) + let tr = oElem doTrace os || null cs -- option -tr leaves trace in pipe + make = oElem (iOpt "make") os + isErr = case arg of + AError _ -> True + _ -> False + utf = if (oElem useUTF8 os) then encodeUTF8 else id + outp = if tr then [utf (prCommandArg val)] else [] + if put then mapM_ putStrLnFlush outp else return () + if make && isErr + then exitFailure + else execs cs val (if put then [] else outps ++ outp, st') + where + execs [] arg st = return st + execs (c:cs) arg st = execLine put (c, arg, cs) st + +-- | individual commands possibly piped: value returned; this is not a state monad +execC :: CommandOpt -> ShellIO +execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case comm of + + CImport file | takeExtensions file == ".gfwl" -> do + fs <- mkWordlist file + foldM (\x y -> execC (CImport y, opts) x) sa fs + + CImport file | oElem fromExamples opts -> do + es <- liftM nub $ getGFEFiles opts file + system $ "gf -examples" +++ unlines es + execC (comm, removeOption fromExamples opts) sa + CImport file -> useIOE sa $ do + st1 <- shellStateFromFiles opts st file + ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a)) + + CEmptyState -> changeState reinitShellState sa + CChangeMain ma -> changeStateErr (changeMain ma) sa + CStripState -> changeState purgeShellState sa + + CRemoveLanguage lan -> changeState (removeLang lan) sa +{- + CTransformGrammar file -> do + s <- transformGrammarFile opts file + returnArg (AString s) sa + CConvertLatex file -> do + s <- readFileIf file + returnArg (AString (convertGFTex s)) sa +-} + CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa + -- good to have here for piping; eh and ec must be done on outer level + + CDefineCommand c args -> return (addShMacro (c,args) sh, AUnit) + CDefineTerm c -> do + let + a' = case a of + ASTrm _ -> s2t a + AString _ -> s2t a + _ -> a + case a' of + ATrms [trm] -> return (addShTerm (c,trm) sh, AUnit) + _ -> returnArg (AError "illegal term definition") sa + + CLinearize [] + | oElem showMulti opts -> + + changeArg (opTS2CommandArg ( + unlines . + (\t -> [optLinearizeTreeVal opts gr t | gr <- allStateGrammars st])) . s2t) sa + + | otherwise -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa +---- CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa + + CParse +---- | oElem showMulti opts -> do + | oElem (iOpt "overload") opts -> do + p <- parse $ prCommandArg a + changeArg (opTTs2CommandArg getOverloadResults) p + | oElem byLines opts -> do + let ss = (if oElem showAll opts then id else filter (not . null)) $ + lines $ prCommandArg a + mts <- mapM parse ss + let mark s ts = case ts of + [] -> [MMacros.uTree] -- to leave a trace of unparsed line + _ -> ts + let a' = ATrms [t | (s,(_,ATrms ts)) <- zip ss mts, t <- mark s ts] + changeArg (const a') sa + | otherwise -> parse $ prCommandArg a + where + parse x = do + warnDiscont opts + let p = optParseArgErrMsg opts gro x + case p of + Ok (ts,msg) + | oElem (iOpt "fail") opts && null ts -> do + putStrLnFlush ("#FAIL:" +++ x) >> changeArg (const $ ATrms ts) sa + | oElem (iOpt "ambiguous") opts && length ts > 1 -> do + putStrLnFlush ("#AMBIGUOUS:" +++ x) >> changeArg (const $ ATrms ts) sa + | oElem (iOpt "prob") opts -> do + let probs = stateProbs gro + let tps = rankByScore [(t,computeProbTree probs t) | t <- ts] + putStrLnFlush msg + mapM_ putStrLnFlush [show p | (t,p) <- tps] + changeArg (const $ ATrms (map fst tps)) sa + | otherwise -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa + Bad msg -> changeArg (const $ AError (msg +++ "input" +++ x)) sa + + CTranslate il ol -> do + let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a + returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa + + CGenerateRandom | oElem showCF opts || oElem (iOpt "prob") opts -> do + let probs = stateProbs gro + let cat = firstAbsCat opts gro + let n = optIntOrN opts flagNumber 1 + gen <- newStdGen + let ts = take n $ generateRandomTreesProb opts gen cgr probs cat + returnArg (ATrms (map (term2tree gro) ts)) sa + + CGenerateRandom -> do + let + a' = case a of + ASTrm _ -> s2t a + AString _ -> s2t a + _ -> a + case a' of + ATrms (trm:_) -> case tree2exp trm of + G.EInt _ -> do + putStrLn "Warning: Number argument deprecated, use gr -number=n instead" + ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1) + returnArg (ATrms ts) sa + _ -> do + g <- newStdGen + case (goFirstMeta (tree2loc trm) >>= refineRandom g 41 cgr) of + Ok trm' -> returnArg (ATrms [loc2tree trm']) sa + Bad s -> returnArg (AError s) sa + _ -> do + ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1) + returnArg (ATrms ts) sa + + CGenerateTrees | oElem showAll opts -> do + let + cat = firstAbsCat opts gro + outp + | oElem (iOpt "lin") opts = optLinearizeTreeVal opts gro . term2tree gro + | otherwise = prt_ + justOutput opts (generateAll opts (putStrLn . outp) cgr cat) sa + CGenerateTrees -> do + let + a' = case a of + ASTrm _ -> s2t a + AString _ -> s2t a + _ -> a + mt = case a' of + ATrms (tr:_) -> Just tr + _ -> Nothing + returnArg (ATrms $ generateTrees opts gro mt) sa + + CTreeBank | oElem doCompute opts -> do -- -c + let bank = prCommandArg a + returnArg (AString $ unlines $ testMultiTreebank opts st bank) sa + CTreeBank | oElem getTrees opts -> do -- -trees + let bank = prCommandArg a + tes = map (string2treeErr gro) $ treesTreebank opts bank + terms = [t | Ok t <- tes] + returnArg (ATrms terms) sa + CTreeBank -> do + let ts = strees $ s2t $ snd sa + comm = "command" ---- + returnArg (AString $ unlines $ mkMultiTreebank opts st comm ts) sa + + CLookupTreebank -> do + let tbs = treebanks st + let s = prCommandArg a + if null tbs + then returnArg (AError "no treebank") sa + else do + let tbi = maybe (fst $ head tbs) I.identC (getOptVal opts (aOpt "treebank")) + case lookup tbi tbs of + Nothing -> returnArg (AError ("no treebank" +++ prt tbi)) sa + Just tb -> case () of + _ | oElem (iOpt "strings") opts -> do + returnArg (AString $ unlines $ map fst $ assocsTreebank tb) sa + _ | oElem (iOpt "raw") opts -> do + returnArg (AString $ unlines $ lookupTreebank tb s) sa + _ | oElem (iOpt "assocs") opts -> do + returnArg (AString $ unlines $ map printAssoc $ assocsTreebank tb) sa + _ | oElem (iOpt "trees") opts -> do + returnArg (ATrms $ str2trees $ concatMap snd $ assocsTreebank tb) sa + _ -> do + let tes = map (string2treeErr gro) $ lookupTreebank tb s + terms = [t | Ok t <- tes] + returnArg (ATrms terms) sa + + CShowTreeGraph | oElem emitCode opts -> do -- -o + returnArg (AString $ visualizeTrees opts $ strees $ s2t a) sa + CShowTreeGraph -> do + let gv = if oElem (iOpt "mac") opts then "open" else "gv" ---- config! + let g0 = writeFile "grphtmp.dot" $ visualizeTrees opts $ strees $ s2t a + g1 = system "dot -Tps grphtmp.dot >grphtmp.ps" + g2 = system (gv +++ "grphtmp.ps &") + g3 = return () ---- system "rm -f grphtmp.*" + justOutput opts (g0 >> g1 >> g2 >> g3 >> return ()) sa + + CPutTerm -> changeArg (opTT2CommandArg (return . optTermCommand opts gro) . s2t) sa + + CWrapTerm f -> changeArg (opTT2CommandArg (return . return . wrapByFun opts gro f) . s2t) sa + CApplyTransfer f -> changeArg (opTT2CommandArg (applyTransfer opts gro transfs f) . s2t) sa + CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa + CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa + + CComputeConcrete t -> do + let prin = if (oElem (iOpt "table") opts) then printParadigm else prt + m <- return $ + maybe (I.identC "?") id $ -- meaningful if no opers in t + maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res + getOptVal opts useResource -- flag -res=m + returnArg (AString (err id (prin . stripTerm) ( + string2srcTerm src m t >>= + Ch.justCheckLTerm src >>= + Co.computeConcrete src))) sa +--- Co.computeConcreteRec src)) sa + CShowOpers t -> do + m <- return $ + maybe (I.identC "?") id $ -- meaningful if no opers in t + maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res + getOptVal opts useResource -- flag -res=m + justOutput opts (putStrLn (err id (unlines . map prOperSignature) ( + string2srcTerm src m t >>= (\t' -> + Co.computeConcrete src t' >>= (\v -> + return (L.opersForType src t' v)))))) sa + + + CTranslationQuiz il ol -> do + warnDiscont opts + justOutput opts (teachTranslation opts (sgr il) (sgr ol)) sa + CTranslationList il ol -> do + warnDiscont opts + let n = optIntOrN opts flagNumber 10 + qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n) + let hdr = unlines ["# From: " ++ prIdent il, + "# To: " ++ prIdent ol] + returnArg (AString $ hdr ++++ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa + + CMorphoQuiz -> do + warnDiscont opts + justOutput opts (teachMorpho opts gro) sa + CMorphoList -> do + let n = optIntOrN opts flagNumber 10 + warnDiscont opts + qs <- useIOE [] $ morphoTrainList opts gro (toInteger n) + returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa + + CReadFile file -> returnArgIO (readFileIf file >>= return . AString) sa + CWriteFile file -> justOutputArg opts (writeFile file) sa + CAppendFile file -> justOutputArg opts (appendFile file) sa + CSpeakAloud -> justOutputArg opts (speechGenerate opts) sa + CSpeechInput -> returnArgIO (speechInput opts gro >>= return . AString . unlines) sa + CSystemCommand s -> case a of + AUnit -> justOutput opts (system s >> return ()) sa + _ -> systemArg opts a s sa + CPutString -> changeArg (opSS2CommandArg (optStringCommand opts gro)) sa +----- CShowTerm -> changeArg (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa + CGrep ms -> changeArg (AString . unlines . filter (grep ms) . lines . prCommandArg) sa + + + CSetFlag -> changeState (addGlobalOptions opts0) sa +---- deprec! CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa + + CHelp (Just c) -> returnArg (AString (txtHelpCommand c)) sa + CHelp _ -> case opts0 of + Opts [o] | o == showAll -> returnArg (AString txtHelpFile) sa + Opts [o] | o == showDefs -> returnArg (AString (txtHelpMacros sh)) sa + Opts [o] -> returnArg (AString (txtHelpCommand ('-':prOpt o))) sa + _ -> returnArg (AString txtHelpFileSummary) sa + + CPrintGrammar -> returnArg (AString (optPrintGrammar opts gro)) sa + CPrintGlobalOptions -> justOutput opts (putStrLn $ prShellStateInfo st) sa + CPrintInformation c -> justOutput opts (useIOE () $ showInformation opts st c) sa + CPrintLanguages -> justOutput opts + (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa + CPrintMultiGrammar -> do + let cgr' = canModules $ purgeShellState st + returnArg (AString (optPrintMultiGrammar opts cgr')) sa + CShowGrammarGraph -> do + ---- sa' <- changeState purgeShellState sa + let gv = if oElem (iOpt "mac") opts then "open" else "gv" ---- config! + let g0 = writeFile "grphtmp.dot" $ visualizeCanonGrammar opts cgr + g1 = system "dot -Tps grphtmp.dot >grphtmp.ps" + g2 = system (gv +++ "grphtmp.ps &") + g3 = return () ---- system "rm -f grphtmp.*" + justOutput opts (g0 >> g1 >> g2 >> g3 >> return ()) sa + CPrintSourceGrammar -> + returnArg (AString (visualizeSourceGrammar src)) sa + +---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa +---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa +---- CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa + _ -> justOutput opts (putStrLn "command not understood") sa + + where + sgr = stateGrammarOfLang st + gro = grammarOfOptState opts st + opts = addOptions opts0 (globalOptions st) + src = srcModules st + cgr = canModules st + + transfs = transfers st + + s2t a = case a of + ASTrm ('$':c) -> maybe (AError "undefined term") (ATrms . return) $ lookupShTerm sh c + ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s + AString s -> err AError (ATrms . return) $ string2treeErr gro s + _ -> a + + str2trees ts = [t | Ok t <- map (string2treeErr gro) ts] + + strees a = case a of + ATrms ts -> ts + _ -> [] + + warnDiscont os = err putStrLn id $ do + let c0 = firstAbsCat os gro + c <- GrammarToCanon.redQIdent c0 + lang <- maybeErr "no concrete" $ languageOfOptState os st + t <- return $ errVal CMacros.defLinType $ Look.lookupLincat cgr $ CMacros.redirectIdent lang c + return $ if CMacros.isDiscontinuousCType t + then (putStrLn ("Warning: discontinuous category" +++ prt_ c)) + else (return ()) + + grep ms s = (if oElem invertGrep opts then not else id) $ grepv ms s --- -v + grepv ms s = case s of + _:cs -> isPrefixOf ms s || grepv ms cs + _ -> isPrefixOf ms s + +-- commands either change the state or process the argument, but not both +-- some commands just do output + +changeState :: ShellStateOper -> ShellIO +changeState f ((st,h),a) = return ((f st,h), a) + +changeStateErr :: ShellStateOperErr -> ShellIO +changeStateErr f ((st,h),a) = case f st of + Ok st' -> return ((st',h), a) + Bad s -> return ((st, h),AError s) + +changeArg :: (CommandArg -> CommandArg) -> ShellIO +changeArg f (st,a) = return (st, f a) + +changeArgMsg :: (CommandArg -> (CommandArg,String)) -> ShellIO +changeArgMsg f (st,a) = do + let (b,msg) = f a + putStrLnFlush msg + return (st, b) + +returnArg :: CommandArg -> ShellIO +returnArg = changeArg . const + +returnArgIO :: IO CommandArg -> ShellIO +returnArgIO io (st,_) = io >>= (\a -> return (st,a)) + +justOutputArg :: Options -> (String -> IO ()) -> ShellIO +justOutputArg opts f sa@(st,a) = f (utf (prCommandArg a)) >> return (st, AUnit) + where + utf = if (oElem useUTF8 opts) then encodeUTF8 else id + +justOutput :: Options -> IO () -> ShellIO +justOutput opts = justOutputArg opts . const + +systemArg :: Options -> CommandArg -> String -> ShellIO +systemArg _ cont syst sa = do + writeFile tmpi $ prCommandArg cont + system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo + s <- readFile tmpo + returnArg (AString s) sa + where + tmpi = "_tmpi" --- + tmpo = "_tmpo" + +-- | type system for command arguments; instead of plain strings... +data CommandArg = + AError String + | ATrms [Tree] + | ASTrm String -- ^ to receive from parser + | AStrs [Str] + | AString String + | AUnit + deriving (Eq, Show) + +prCommandArg :: CommandArg -> String +prCommandArg arg = case arg of + AError s -> s + AStrs ss -> sstrV ss + AString s -> s + ATrms [] -> "no tree found" + ATrms tt -> unlines $ map prt_Tree tt + ASTrm s -> s + AUnit -> "" + +opSS2CommandArg :: (String -> String) -> CommandArg -> CommandArg +opSS2CommandArg f = AString . f . prCommandArg + +opST2CommandArg :: (String -> Err [Tree]) -> CommandArg -> CommandArg +opST2CommandArg f = err AError ATrms . f . prCommandArg + +opTS2CommandArg :: (Tree -> String) -> CommandArg -> CommandArg +opTS2CommandArg f (ATrms ts) = AString $ unlines $ map f ts +opTS2CommandArg _ (AError s) = AError ("expected term, but got error:" ++++ s) +opTS2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a) + +opTT2CommandArg :: (Tree -> Err [Tree]) -> CommandArg -> CommandArg +opTT2CommandArg f (ATrms ts) = err AError (ATrms . concat) $ mapM f ts +opTT2CommandArg _ (AError s) = AError ("expected term, but got error:" ++++ s) +opTT2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a) + +opTTs2CommandArg :: ([Tree] -> [Tree]) -> CommandArg -> CommandArg +opTTs2CommandArg f (ATrms ts) = ATrms $ f ts +opTTs2CommandArg _ (AError s) = AError ("expected terms, but got error:" ++++ s) +opTTs2CommandArg _ a = AError ("expected terms, but got:" ++++ prCommandArg a) + diff --git a/src-3.0/GF/Shell/CommandL.hs b/src-3.0/GF/Shell/CommandL.hs new file mode 100644 index 000000000..efb6460b4 --- /dev/null +++ b/src-3.0/GF/Shell/CommandL.hs @@ -0,0 +1,198 @@ +---------------------------------------------------------------------- +-- | +-- Module : CommandL +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/17 15:13:55 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.21 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Shell.CommandL where + +import GF.Data.Operations +import GF.Infra.UseIO + +import GF.Canon.CMacros +import GF.Grammar.Values (Tree) + +import GF.UseGrammar.GetTree +import GF.Compile.ShellState +import GF.Infra.Option +import GF.UseGrammar.Session +import GF.Shell.Commands +import GF.UseGrammar.Tokenize (wordsLits) + +import Data.Char +import Data.List (intersperse) +import Control.Monad (foldM) + +import GF.Text.UTF8 + +-- | a line-based shell +initEditLoop :: CEnv -> IO () -> IO () +initEditLoop env resume = do + let env' = startEditEnv env + putStrLnFlush $ initEditMsg env' + let state = initSStateEnv env' + putStrLnFlush $ showCurrentState env' state + editLoop env' state resume + +editLoop :: CEnv -> SState -> IO () -> IO () +editLoop env state resume = do + putStrFlush "edit> " + c <- getCommand + if (isQuit c) then resume else do + (env',state') <- execCommand env c state + let package = case c of + CCEnvEmptyAndImport _ -> initEditMsgEmpty env' + _ -> showCurrentState env' state' + putStrLnFlush package + + editLoop env' state' resume + +-- | execute a command script and return a tree +execCommandHistory :: CEnv -> String -> IO (CEnv,Tree) +execCommandHistory env s = do + let env' = startEditEnv env + let state = initSStateEnv env' + (env',state') <- foldM exec (env,state) $ lines s + return $ (env',treeSState state') + + where + + exec (env,state) l = do + let c = pCommand l + execCommand env c state + + + +getCommand :: IO Command +getCommand = do + s <- getLine + return $ pCommand s + +-- | decodes UTF8 if u==True, i.e. if the grammar uses UTF8; +-- used in the Java GUI, which always uses UTF8 +getCommandUTF :: Bool -> IO [(String,Command)] +getCommandUTF u = do + s <- getLine + return $ pCommandMsgs $ if u then decodeUTF8 s else s + +pCommandMsgs :: String -> [(String,Command)] +pCommandMsgs = map (pCommandMsg . unwords) . concatMap (chunks ";;" . words) . lines + +pCommand :: String -> Command +pCommand = snd . pCommandMsg + + +pCommandMsg :: String -> (String,Command) +pCommandMsg s = (m,pCommandWords $ words c) where + (m,c) = case s of + '[':s2 -> let (a,b) = span (/=']') s2 in (a,drop 1 b) + _ -> ("",s) + pCommandWords s = case s of + "n" : cat : _ -> CNewCat cat + "t" : ws -> CNewTree $ unwords ws + "g" : ws -> CRefineWithTree $ unwords ws -- example: *g*ive + "p" : ws -> CRefineParse $ unwords ws + "rc": i : _ -> CRefineWithClip (readIntArg i) + ">" : i : _ -> CAhead $ readIntArg i + ">" : [] -> CAhead 1 + "<" : i : _ -> CBack $ readIntArg i + "<" : [] -> CBack 1 + ">>" : _ -> CNextMeta + "<<" : _ -> CPrevMeta + "'" : _ -> CTop + "+" : _ -> CLast + "mp" : p -> CMovePosition (readIntList (unwords p)) + "ct" : p:q:_ -> CCopyPosition (readIntList p) (readIntList q) + "r" : f : _ -> CRefineWithAtom f + "w" : f:i : _ -> CWrapWithFun (f, readIntArg i) + "ch": f : _ -> CChangeHead f + "ph": f:i : _ -> CPeelHead (f, readIntArg i) + "x" : ws -> CAlphaConvert $ unwords ws + "s" : i : _ -> CSelectCand (readIntArg i) + "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm + "f" : "structured" : _ -> CAddOption showStruct --- hmmm + "f" : s : _ -> CAddOption (filterString s) + "u" : i : _ -> CUndo (readIntArg i) + "u" : _ -> CUndo 1 + "d" : _ -> CDelete + "ac" : _ -> CAddClip + "pc": i : _ -> CRemoveClip (readIntArg i) + "c" : s : _ -> CTermCommand s + "a" : _ -> CRefineRandom --- *a*leatoire + "m" : _ -> CMenu + "ml" : s : _ -> changeMenuLanguage s + "ms" : s : _ -> changeMenuSize s + "mt" : s : _ -> changeMenuTyped s + "v" : _ -> CView + "q" : _ -> CQuit + "h" : _ -> CHelp initEditMsg + + "i" : file: _ -> CCEnvImport file + "e" : [] -> CCEnvEmpty + "e" : file: _ -> CCEnvEmptyAndImport file + + "open" : f: _ -> CCEnvOpenTerm f + "openstring": f: _ -> CCEnvOpenString f + + "on" :lang: _ -> CCEnvOn lang + "off":lang: _ -> CCEnvOff lang + "pfile" :f:_ -> CCEnvRefineParse f + "tfile" :f:_ -> CCEnvRefineWithTree f + "save":l:f:_ -> CCEnvSave l f + +-- openstring file +-- pfile file +-- tfile file +-- on lang +-- off lang + + "gf": comm -> CCEnvGFShell (unwords comm) + + [] -> CVoid + _ -> CError + +-- | well, this lists the commands of the line-based editor +initEditMsg :: CEnv -> String +initEditMsg env = unlines $ + "State-dependent editing commands are given in the menu:" : + " n [Cat] = new, r [Fun] = refine, w [Fun] [Int] = wrap,": + " ch [Fun] = change head, d = delete, s [Int] = select," : + " x [Var] [Var] = alpha convert." : + "Commands changing the environment:" : + " i [file] = import, e = empty." : + "Other commands:" : + " a = random, v = change view, u = undo, h = help, q = quit," : + " ml [Lang] = change menu language," : + " ms (short | long) = change menu command size," : + " mt (typed | untyped) = change menu item typing," : + " p [string] = refine by parsing, g [term] = refine by term," : + " > = down, < = up, ' = top, >> = next meta, << = previous meta." : +---- (" c [" ++ unwords (intersperse "|" allTermCommands) ++ "] = modify term") : +---- (" f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") : + [] + +initEditMsgEmpty :: CEnv -> String +initEditMsgEmpty env = initEditMsg env +++++ unlines ( + "Start editing by n Cat selecting category\n\n" : + "-------------\n" : + ["n" +++ cat | (_,cat) <- newCatMenu env] + ) + +showCurrentState :: CEnv -> SState -> String +showCurrentState env' state' = + unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) + where (tr,msg,menu) = displaySStateIn env' state' + +-- | to read position; borrowed from Prelude; should be elsewhere +readIntList :: String -> [Int] +readIntList s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + _ -> [] diff --git a/src-3.0/GF/Shell/Commands.hs b/src-3.0/GF/Shell/Commands.hs new file mode 100644 index 000000000..8699c2fe7 --- /dev/null +++ b/src-3.0/GF/Shell/Commands.hs @@ -0,0 +1,568 @@ +---------------------------------------------------------------------- +-- | +-- Module : Commands +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/06 10:02:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.42 $ +-- +-- temporary hacks for GF 2.0 +-- +-- Abstract command language for syntax editing. AR 22\/8\/2001. +-- Most arguments are strings, to make it easier to receive them from e.g. Java. +-- See "CommandsL" for a parser of a command language. +----------------------------------------------------------------------------- + +module GF.Shell.Commands where + +import GF.Data.Operations +import GF.Data.Zipper + +import qualified GF.Grammar.Grammar as G ---- Cat, Fun, Q, QC +import GF.Canon.GFC +import GF.Canon.CMacros +import GF.Grammar.Macros (qq)---- +import GF.Grammar.LookAbs +import GF.Canon.Look +import GF.Grammar.Values (loc2treeFocus,tree2exp)---- + +import GF.UseGrammar.GetTree +import GF.API +import GF.Compile.ShellState + +import qualified GF.Shell as Shell +import qualified GF.Shell.PShell as PShell +import qualified GF.Grammar.Macros as M +import GF.Grammar.PrGrammar +import GF.Compile.PGrammar +import GF.API.IOGrammar +import GF.Infra.UseIO +import GF.Text.Unicode + +import GF.CF.CF +import GF.CF.CFIdent (cat2CFCat, cfCat2Cat) +import GF.CF.PPrCF (prCFCat) +import GF.UseGrammar.Linear +import GF.UseGrammar.Randomized +import GF.UseGrammar.Editing +import GF.UseGrammar.Session +import GF.UseGrammar.Custom + +import qualified GF.Infra.Ident as I +import GF.Infra.Option +import GF.Data.Str (sstr) ---- +import GF.Text.UTF8 ---- + +import System.Random (StdGen, mkStdGen, newStdGen) +import Control.Monad (liftM2, foldM) +import Data.List (intersperse) + +--- temporary hacks for GF 2.0 + +-- Abstract command language for syntax editing. AR 22/8/2001 +-- Most arguments are strings, to make it easier to receive them from e.g. Java. +-- See CommandsL for a parser of a command language. + +data Command = + CNewCat String + | CNewTree String + | CAhead Int + | CBack Int + | CNextMeta + | CPrevMeta + | CTop + | CLast + | CMovePosition [Int] + | CCopyPosition [Int] [Int] + | CRefineWithTree String + | CRefineWithClip Int + | CRefineWithAtom String + | CRefineParse String + | CWrapWithFun (String,Int) + | CChangeHead String + | CPeelHead (String,Int) + | CAlphaConvert String + | CRefineRandom + | CSelectCand Int + | CTermCommand String + | CAddOption Option + | CRemoveOption Option + | CDelete + | CAddClip + | CRemoveClip Int + | CUndo Int + | CView + | CMenu + | CQuit + | CHelp (CEnv -> String) -- ^ help message depends on grammar and interface + | CError -- ^ syntax error in command + | CVoid -- ^ empty command, e.g. just \ + + | CCEnvImport String -- ^ |-- commands affecting 'CEnv' + | CCEnvEmptyAndImport String -- ^ | + | CCEnvOpenTerm String -- ^ | + | CCEnvOpenString String -- ^ | + | CCEnvEmpty -- ^ | + + | CCEnvOn String -- ^ | + | CCEnvOff String -- ^ | + + | CCEnvGFShell String -- ^ |========== + + | CCEnvRefineWithTree String -- ^ |-- other commands using 'IO' + | CCEnvRefineParse String -- ^ | + | CCEnvSave String FilePath -- ^ |========== + +isQuit :: Command -> Bool +isQuit CQuit = True +isQuit _ = False + +-- | an abstract environment type +type CEnv = ShellState + +grammarCEnv :: CEnv -> StateGrammar +grammarCEnv = firstStateGrammar + +canCEnv :: CEnv -> CanonGrammar +canCEnv = canModules + +concreteCEnv, abstractCEnv :: StateGrammar -> I.Ident +concreteCEnv = cncId +abstractCEnv = absId + +stdGenCEnv :: CEnv -> SState -> StdGen +stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- + +initSStateEnv :: CEnv -> SState +initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of + Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState + _ -> initSState + where + sgr = firstStateGrammar env + abs = absId sgr + gr = stateGrammarST sgr + +-- | the main function +execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState) +execCommand env c s = case c of + +-- these commands do need IO + CCEnvImport file -> useIOE (env,s) $ do + st <- shellStateFromFiles optss env file + return (st,s) + + CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do + st <- shellStateFromFiles optss emptyShellState file + return (startEditEnv st,initSState) + + CCEnvEmpty -> do + return (startEditEnv emptyShellState, initSState) + + CCEnvGFShell command -> do + let hs = Shell.initHState env + let cs = PShell.pCommandLines hs command + (msg,(env',_)) <- Shell.execLines False cs hs + return (env', changeMsg msg s) ---- + + CCEnvOpenTerm file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c +---- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec +---- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs + let env' = env ---- + return (env', execECommand env' (CNewTree t) s) + + CCEnvOpenString file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c +---- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec +---- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs + let env' = env ---- + return (env', execECommand env' (CRefineParse t) s) + + CCEnvOn name -> return (languageOn (language name) env,s) + CCEnvOff name -> return (languageOff (language name) env,s) + + CCEnvSave lang file -> do + let str = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) $ treeSState s + writeFile file str + let msg = ["wrote file" +++ file] + return (env,changeMsg msg s) + +-- this command is improved by the use of IO + CRefineRandom -> do + g <- newStdGen + return (env, action2commandNext (refineRandom g 41 cgr) s) + +-- these commands use IO + CCEnvRefineWithTree file -> do + str <- readFileIf file + execCommand env (CRefineWithTree str) s + CCEnvRefineParse file -> do + str <- readFileIf file + execCommand env (CRefineParse str) s + +-- other commands don't need IO; they are available in the fudget + c -> return (env, execECommand env c s) + + where + gr = grammarCEnv env + cgr = canCEnv env + opts = globalOptions env + optss = addOption beSilent opts + + -- format for documents: + -- GF commands of form "-- command", then term or text + envAndTerm f s = + (unwords (intersperse ";;" fs), unlines ss) where + (fs,ss) = span isImport (lines s) + isImport l = take 2 l == "--" + + +execECommand :: CEnv -> Command -> ECommand +execECommand env c = case c of + CNewCat cat -> action2commandNext $ \x -> do + cat' <- string2cat sgr cat + s' <- newCat cgr cat' x + uniqueRefinements cgr s' + CNewTree s -> action2commandNext $ \x -> do + t <- string2treeErr gr s + s' <- newTree t x + uniqueRefinements cgr s' + CAhead n -> action2command (goAheadN n) + CBack n -> action2command (goBackN n) + CTop -> action2command $ return . goRoot + CLast -> action2command $ goLast + CMovePosition p -> action2command $ goPosition p + CNextMeta -> action2command goNextNewMeta + CPrevMeta -> action2command goPrevNewMeta + CRefineWithAtom s -> action2commandNext $ \x -> do + t <- string2ref gr s + s' <- refineWithAtom der cgr t x + uniqueRefinements cgr s' + CWrapWithFun (f,i) -> action2commandKeep $ wrapWithFun cgr (qualif f, i) + CChangeHead f -> action2commandKeep $ changeFunHead cgr (qualif f) + CPeelHead (f,i) -> action2commandKeep $ peelFunHead cgr (qualif f,i) + + CAlphaConvert s -> action2commandKeep $ \x -> + string2varPair s >>= \xy -> alphaConvert cgr xy x + + CRefineWithTree s -> action2commandNext $ \x -> + (string2treeInState gr s x >>= + \t -> refineWithTree der cgr t x) + CRefineWithClip i -> \s -> + let et = getNumberedClip i s + in (case et of + Ok t -> refineByTrees der cgr [t] s + Bad m -> changeMsg [m] s) + CCopyPosition p q -> action2command $ \s -> do + s1 <- goPosition p s + let t = actTree s1 + s2 <- goPosition q s1 + let compat = actVal s1 == actVal s2 + if compat + then refineWithTree der cgr t s2 + else return s + + CRefineParse str -> \s -> + let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s))) + ts = parseAny agrs cat str + in (if null ts ---- debug + then withMsg ["parse failed in cat" +++ prCFCat cat] + else id) + (refineByTrees der cgr ts) s + + CRefineRandom -> \s -> action2commandNext + (refineRandom (stdGenCEnv env s) 41 cgr) s + + CSelectCand i -> selectCand cgr i + + CTermCommand c -> case c of + "reindex" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s + "paraphrase" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s +---- "transfer" -> action2commandNext $ +---- transferSubTree (stateTransferFun sgr) gr + "generate" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s + _ -> replaceByEditCommand gr c + + CAddOption o -> changeStOptions (addOption o) + CRemoveOption o -> changeStOptions (removeOption o) + CDelete -> action2commandKeep $ deleteSubTree cgr + CAddClip -> \s -> (addtoClip (actTree (stateSState s))) s + CRemoveClip n -> \s -> (removeClip n) s + CUndo n -> undoCommand n + CMenu -> \s -> changeMsg (menuState env s) s + CView -> changeView + CHelp h -> changeMsg [h env] + CVoid -> id + _ -> changeMsg ["command not yet implemented"] + where + sgr = firstStateGrammar env + agrs = allActiveGrammars env + cgr = canCEnv env + gr = grammarCEnv env + der = maybe True not $ caseYesNo (globalOptions env) noDepTypes + -- if there are dep types, then derived refs; deptypes is the default + abs = absId sgr + qualif = string2Fun gr + +-- + + +string2varPair :: String -> Err (I.Ident,I.Ident) +string2varPair s = case words s of + x : y : [] -> liftM2 (,) (string2ident x) (string2ident y) + _ -> Bad "expected format 'x y'" + + +startEditEnv :: CEnv -> CEnv +startEditEnv env = addGlobalOptions (options [sizeDisplay "short"]) env + +-- | seen on display +cMenuDisplay :: String -> Command +cMenuDisplay s = CAddOption (menuDisplay s) + +newCatMenu :: CEnv -> [(Command, String)] +newCatMenu env = [(CNewCat (prQIdent c), printname env initSState c) | + (c,[]) <- allCatsOf (canCEnv env)] + +mkRefineMenu :: CEnv -> SState -> [(Command,String)] +mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate] + +mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))] +mkRefineMenuAll env sstate = + case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of + ([],[],wraps) -> + [(CWrapWithFun (prQIdent_ f, i), prWrap "w" "Wrap" fit) + | fit@((f,i),_) <- wraps] ++ + [(CChangeHead (prQIdent_ f), prChangeHead f) + | f <- headChangesState cgr state] ++ + [(CPeelHead (prQIdent_ f, i), prPeel "ph" "PeelHead" fi) + | fi@(f,i) <- peelingsState cgr state] ++ + [(CDelete, (ifShort "d" "Delete", "d"))] ++ + [(CAddClip, (ifShort "ac" "AddClip", "ac"))] + (refs,[],_) -> + [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] ++ + [(CRefineWithClip i, prClip i t) | (i,t) <- possClipsSState gr sstate] + (_,cands,_) -> + [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] + + where + prRef (f,(t,_)) = + (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt_ t), + "r" +++ prRefinement f) + prClip i t = + (ifShort "rc" "Paste" +++ prOrLinTree t, + "rc" +++ show i) + prChangeHead f = + (ifShort "ch" "ChangeHead" +++ prOrLinFun f, + "ch" +++ prQIdent_ f) + prWrap sh lg ((f,i),t) = + (ifShort sh lg +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ + ifShort (show i) (prBracket (show i)), + sh +++ prQIdent_ f +++ show i) + prPeel sh lg (f,i) = + (ifShort sh lg +++ prOrLinFun f +++ + ifShort (show i) (prBracket (show i)), + sh +++ prQIdent_ f +++ show i) + prCand (t,i) = + (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i) + + gr = grammarCEnv env + cgr = canCEnv env + state = stateSState sstate + opts = addOptions (optsSState sstate) (globalOptions env) + ifOpt f v a b = case getOptVal opts f of + Just s | s == v -> a + _ -> b + ifShort = ifOpt sizeDisplay "short" + ifTyped t = ifOpt typeDisplay "typed" t "" + prOrLinExp t = err (const $ prt_ t) prOrLinTree $ annotateInState cgr t state + prOrLinRef t = case t of + G.Q m f -> printname env sstate (m,f) + G.QC m f -> printname env sstate (m,f) + _ -> prt_ t + prOrLinFun = printname env sstate + prOrLinTree t = case getOptVal opts menuDisplay of + Just "Abs" -> prt_ $ tree2exp t ---- prTermOpt opts $ tree2exp t + Just lang -> prQuotedString $ lin lang t + _ -> prTermOpt opts $ tree2exp t + lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t + +-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped +-- the default is Abs, long, untyped; the Menus menu changes the parameter + +emptyMenuItem :: (Command, (String, String)) +emptyMenuItem = (CVoid,("","")) + + + +---- allStringCommands = snd $ customInfo customStringCommand +termCommandMenu :: [(Command,String)] +termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] + +allTermCommands :: [String] +allTermCommands = snd $ customInfo customEditCommand + +stringCommandMenu :: [(Command,String)] +stringCommandMenu = [] + +displayCommandMenu :: CEnv -> [(Command,String)] +displayCommandMenu env = + [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ + [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ + [(fo nostripQualif, s) | (fo,s) <- [(CAddOption,"qualified"), + (CRemoveOption,"unqualified")]] ++ + [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] + where + langs = map prLanguage $ allLanguages env + +{- ---- + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] +-} + +changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command +changeMenuLanguage s = CAddOption (menuDisplay s) +changeMenuSize s = CAddOption (sizeDisplay s) +changeMenuTyped s = CAddOption (typeDisplay s) + +menuState :: CEnv -> SState -> [String] +menuState env = map snd . mkRefineMenu env + +prState :: State -> [String] +prState s = prMarkedTree (loc2treeMarked s) + +displayJustStateIn :: CEnv -> SState -> String +displayJustStateIn env state = case displaySStateIn env state of + (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF + +displaySStateIn :: CEnv -> SState -> ([String],[String],[(String,String)]) +displaySStateIn env state = (tree',msg,menu) where + (tree,msg,menu) = displaySState env state + grs = allStateGrammars env + lang = (viewSState state) `mod` (length grs + 3) + tree' = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang + opts = addOptions (optsSState state) -- state opts override + (addOption (markLin markOptFocus) (globalOptions env)) + lin g = linearizeState fudWrap opts g zipper + exp = return $ tree2string $ loc2tree zipper + zipper = stateSState state + linAll = map lin grs + separ = singleton . map unlines . intersperse [replicate 72 '*'] + +-- | the Boolean is a temporary hack to have two parallel GUIs +displaySStateJavaX :: Bool -> CEnv -> SState -> String -> String +displaySStateJavaX isNew env state m = encodeUTF8 $ mkUnicode $ + unlines $ tagXML "gfedit" $ concat [ + if null m then [] else tagXML "hmsg" [m], + tagXML "linearizations" (concat + [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]), + tagXML "tree" tree, + tagXML "message" msg, + tagXML "menu" (tagsXML "item" menu') + ] + where + (tree,msg,menu) = displaySState env state + menu' = [tagXML "show" [unicode s] ++ tagXML "send" [c] | (s,c) <- menu] + (ls,grs) = unzip $ lgrs + lgrs = allActiveStateGrammarsWithNames env + lins = (langAbstract, exp) : linAll + opts = addOptions (optsSState state) -- state opts override + (addOption (markLin mark) (globalOptions env)) + lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where + uni = optDecodeUTF8 gr + exp = prprTree $ loc2tree zipper + zipper = stateSState state + linAll = map lin lgrs + gr = firstStateGrammar env + mark = markOptXML -- markOptJava + + unicode = case getOptVal opts menuDisplay of + Just lang -> optDecodeUTF8 (stateGrammarOfLang env (language lang)) + _ -> id + +-- | the env is UTF8 if the display language is +-- +-- should be independent +isCEnvUTF8 :: CEnv -> SState -> Bool +isCEnvUTF8 env st = maybe False id $ do + lang <- getOptVal opts menuDisplay + co <- getOptVal (stateOptions (stateGrammarOfLang env (language lang))) uniCoding + return $ co == "utf8" + where + opts = addOptions (optsSState st) (globalOptions env) + +langAbstract, langXML :: I.Ident +langAbstract = language "Abstract" +langXML = language "XML" + +linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] +linearizeState wrap opts gr = + wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus + + where + unt = customOrDefault (stateOptions gr) useUntokenizer customUntokenizer gr + strop = maybe id ($ gr) $ customAsOptVal opts filterString customStringCommand + br = oElem showStruct opts + +noWrap, fudWrap :: String -> [String] +noWrap = lines +fudWrap = lines . wrapLines 0 --- + +displaySState :: CEnv -> SState -> ([String],[String],[(String,String)]) +displaySState env state = + (prState (stateSState state), msgSState state, menuSState env state) + +menuSState :: CEnv -> SState -> [(String,String)] +menuSState env state = if null cs then [("[NO ALTERNATIVE]","")] else cs + where + cs = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state] + +printname :: CEnv -> SState -> G.Fun -> String +printname env state f = case getOptVal opts menuDisplay of + Just "Abs" -> prQIdent_ f + Just lang -> printn lang f + _ -> prQIdent_ f ---- prTermOpt opts (qq f) + where + opts = addOptions (optsSState state) (globalOptions env) + printn lang f = err id (ifNull (prQIdent_ f) (sstr . head)) $ do + t <- lookupPrintname gr mf + strsFromTerm t + where + sgr = stateGrammarOfLang env (language lang) + gr = grammar sgr + mf = ciq (cncId sgr) (snd f) + +-- * XML printing; does not belong here! + +tagsXML :: String -> [[String]] -> [String] +tagsXML t = concatMap (tagXML t) + +tagAttrXML :: String -> (String, String) -> [String] -> [String] +tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] + +tagXML :: String -> [String] -> [String] +tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] + +mkTagXML :: String -> String +mkTagXML t = '<':t ++ ">" + +mkEndTagXML :: String -> String +mkEndTagXML t = mkTagXML ('/':t) + +mkTagAttrsXML :: String -> [(String, String)] -> String +mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" + +mkTagAttrXML :: String -> (String, String) -> String +mkTagAttrXML t av = mkTagAttrsXML t [av] + diff --git a/src-3.0/GF/Shell/HelpFile.hs b/src-3.0/GF/Shell/HelpFile.hs new file mode 100644 index 000000000..43fae7c42 --- /dev/null +++ b/src-3.0/GF/Shell/HelpFile.hs @@ -0,0 +1,723 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Shell.HelpFile +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/12 10:03:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.9 $ +-- +-- Help on shell commands. Generated from HelpFile by 'make help'. +-- PLEASE DON'T EDIT THIS FILE. +----------------------------------------------------------------------------- + + +module GF.Shell.HelpFile where + +import GF.Data.Operations + +txtHelpFileSummary = + unlines $ map (concat . take 1 . lines) $ paragraphs txtHelpFile + +txtHelpCommand c = + case lookup c [(takeWhile (/=',') p,p) | p <- paragraphs txtHelpFile] of + Just s -> s + _ -> "Command not found." + +txtHelpFile = + "\n-- GF help file updated for GF 2.6, 17/6/2006." ++ + "\n-- *: Commands and options marked with * are currently not implemented." ++ + "\n--" ++ + "\n-- Each command has a long and a short name, options, and zero or more" ++ + "\n-- arguments. Commands are sorted by functionality. The short name is" ++ + "\n-- given first." ++ + "\n" ++ + "\n-- Type \"h -all\" for full help file, \"h \" for full help on a command. " ++ + "\n" ++ + "\n-- commands that change the state" ++ + "\n" ++ + "\ni, import: i File" ++ + "\n Reads a grammar from File and compiles it into a GF runtime grammar." ++ + "\n Files \"include\"d in File are read recursively, nubbing repetitions." ++ + "\n If a grammar with the same language name is already in the state," ++ + "\n it is overwritten - but only if compilation succeeds. " ++ + "\n The grammar parser depends on the file name suffix:" ++ + "\n .gf normal GF source" ++ + "\n .gfc canonical GF" ++ + "\n .gfr precompiled GF resource " ++ + "\n .gfcm multilingual canonical GF" ++ + "\n .gfe example-based grammar files (only with the -ex option)" ++ + "\n .gfwl multilingual word list (preprocessed to abs + cncs)" ++ + "\n .ebnf Extended BNF format" ++ + "\n .cf Context-free (BNF) format" ++ + "\n .trc TransferCore format" ++ + "\n options:" ++ + "\n -old old: parse in GF<2.0 format (not necessary)" ++ + "\n -v verbose: give lots of messages " ++ + "\n -s silent: don't give error messages" ++ + "\n -src from source: ignore precompiled gfc and gfr files" ++ + "\n -gfc from gfc: use compiled modules whenever they exist" ++ + "\n -retain retain operations: read resource modules (needed in comm cc) " ++ + "\n -nocf don't build old-style context-free grammar (default without HOAS)" ++ + "\n -docf do build old-style context-free grammar (default with HOAS)" ++ + "\n -nocheckcirc don't eliminate circular rules from CF " ++ + "\n -cflexer build an optimized parser with separate lexer trie" ++ + "\n -noemit do not emit code (default with old grammar format)" ++ + "\n -o do emit code (default with new grammar format)" ++ + "\n -ex preprocess .gfe files if needed" ++ + "\n -prob read probabilities from top grammar file (format --# prob Fun Double)" ++ + "\n -treebank read a treebank file to memory (xml format)" ++ + "\n flags:" ++ + "\n -abs set the name used for abstract syntax (with -old option)" ++ + "\n -cnc set the name used for concrete syntax (with -old option)" ++ + "\n -res set the name used for resource (with -old option)" ++ + "\n -path use the (colon-separated) search path to find modules" ++ + "\n -optimize select an optimization to override file-defined flags" ++ + "\n -conversion select parsing method (values strict|nondet)" ++ + "\n -probs read probabilities from file (format (--# prob) Fun Double)" ++ + "\n -preproc use a preprocessor on each source file" ++ + "\n -noparse read nonparsable functions from file (format --# noparse Funs) " ++ + "\n examples:" ++ + "\n i English.gf -- ordinary import of Concrete" ++ + "\n i -retain german/ParadigmsGer.gf -- import of Resource to test" ++ + "\n" ++ + "\nr, reload: r" ++ + "\n Executes the previous import (i) command." ++ + "\n " ++ + "\nrl, remove_language: rl Language" ++ + "\n Takes away the language from the state." ++ + "\n" ++ + "\ne, empty: e" ++ + "\n Takes away all languages and resets all global flags." ++ + "\n" ++ + "\nsf, set_flags: sf Flag*" ++ + "\n The values of the Flags are set for Language. If no language" ++ + "\n is specified, the flags are set globally." ++ + "\n examples:" ++ + "\n sf -nocpu -- stop showing CPU time" ++ + "\n sf -lang=Swe -- make Swe the default concrete" ++ + "\n" ++ + "\ns, strip: s" ++ + "\n Prune the state by removing source and resource modules." ++ + "\n" ++ + "\ndc, define_command Name Anything" ++ + "\n Add a new defined command. The Name must star with '%'. Later," ++ + "\n if 'Name X' is used, it is replaced by Anything where #1 is replaced" ++ + "\n by X. " ++ + "\n Restrictions: Currently at most one argument is possible, and a defined" ++ + "\n command cannot appear in a pipe. " ++ + "\n To see what definitions are in scope, use help -defs." ++ + "\n examples:" ++ + "\n dc %tnp p -cat=NP -lang=Eng #1 | l -lang=Swe -- translate NPs" ++ + "\n %tnp \"this man\" -- translate and parse" ++ + "\n" ++ + "\ndt, define_term Name Tree" ++ + "\n Add a constant for a tree. The constant can later be called by" ++ + "\n prefixing it with '$'. " ++ + "\n Restriction: These terms are not yet usable as a subterm. " ++ + "\n To see what definitions are in scope, use help -defs." ++ + "\n examples:" ++ + "\n p -cat=NP \"this man\" | dt tm -- define tm as parse result" ++ + "\n l -all $tm -- linearize tm in all forms" ++ + "\n" ++ + "\n-- commands that give information about the state" ++ + "\n" ++ + "\npg, print_grammar: pg" ++ + "\n Prints the actual grammar (overridden by the -lang=X flag)." ++ + "\n The -printer=X flag sets the format in which the grammar is" ++ + "\n written." ++ + "\n N.B. since grammars are compiled when imported, this command" ++ + "\n generally does not show the grammar in the same format as the" ++ + "\n source. In particular, the -printer=latex is not supported. " ++ + "\n Use the command tg -printer=latex File to print the source " ++ + "\n grammar in LaTeX." ++ + "\n options:" ++ + "\n -utf8 apply UTF8-encoding to the grammar" ++ + "\n flags: " ++ + "\n -printer" ++ + "\n -lang" ++ + "\n -startcat -- The start category of the generated grammar." ++ + "\n Only supported by some grammar printers." ++ + "\n examples:" ++ + "\n pg -printer=cf -- show the context-free skeleton" ++ + "\n" ++ + "\npm, print_multigrammar: pm" ++ + "\n Prints the current multilingual grammar in .gfcm form." ++ + "\n (Automatically executes the strip command (s) before doing this.)" ++ + "\n options:" ++ + "\n -utf8 apply UTF8 encoding to the tokens in the grammar" ++ + "\n -utf8id apply UTF8 encoding to the identifiers in the grammar" ++ + "\n examples:" ++ + "\n pm | wf Letter.gfcm -- print the grammar into the file Letter.gfcm" ++ + "\n pm -printer=graph | wf D.dot -- then do 'dot -Tps D.dot > D.ps'" ++ + "\n" ++ + "\nvg, visualize_graph: vg" ++ + "\n Show the dependency graph of multilingual grammar via dot and gv." ++ + "\n" ++ + "\npo, print_options: po" ++ + "\n Print what modules there are in the state. Also" ++ + "\n prints those flag values in the current state that differ from defaults." ++ + "\n" ++ + "\npl, print_languages: pl" ++ + "\n Prints the names of currently available languages." ++ + "\n" ++ + "\npi, print_info: pi Ident" ++ + "\n Prints information on the identifier." ++ + "\n" ++ + "\n-- commands that execute and show the session history" ++ + "\n" ++ + "\neh, execute_history: eh File" ++ + "\n Executes commands in the file." ++ + "\n" ++ + "\nph, print_history; ph" ++ + "\n Prints the commands issued during the GF session." ++ + "\n The result is readable by the eh command." ++ + "\n examples:" ++ + "\n ph | wf foo.hist\" -- save the history into a file" ++ + "\n" ++ + "\n-- linearization, parsing, translation, and computation" ++ + "\n" ++ + "\nl, linearize: l PattList? Tree" ++ + "\n Shows all linearization forms of Tree by the actual grammar" ++ + "\n (which is overridden by the -lang flag). " ++ + "\n The pattern list has the form [P, ... ,Q] where P,...,Q follow GF " ++ + "\n syntax for patterns. All those forms are generated that match with the" ++ + "\n pattern list. Too short lists are filled with variables in the end." ++ + "\n Only the -table flag is available if a pattern list is specified." ++ + "\n HINT: see GF language specification for the syntax of Pattern and Term." ++ + "\n You can also copy and past parsing results." ++ + "\n options: " ++ + "\n -struct bracketed form" ++ + "\n -table show parameters (not compatible with -record, -all)" ++ + "\n -record record, i.e. explicit GF concrete syntax term (not compatible with -table, -all)" ++ + "\n -all show all forms and variants (not compatible with -record, -table)" ++ + "\n -multi linearize to all languages (can be combined with the other options)" ++ + "\n flags:" ++ + "\n -lang linearize in this grammar" ++ + "\n -number give this number of forms at most" ++ + "\n -unlexer filter output through unlexer" ++ + "\n examples:" ++ + "\n l -lang=Swe -table -- show full inflection table in Swe" ++ + "\n" ++ + "\np, parse: p String" ++ + "\n Shows all Trees returned for String by the actual" ++ + "\n grammar (overridden by the -lang flag), in the category S (overridden" ++ + "\n by the -cat flag)." ++ + "\n options for batch input:" ++ + "\n -lines parse each line of input separately, ignoring empty lines" ++ + "\n -all as -lines, but also parse empty lines" ++ + "\n -prob rank results by probability" ++ + "\n -cut stop after first lexing result leading to parser success" ++ + "\n -fail show strings whose parse fails prefixed by #FAIL" ++ + "\n -ambiguous show strings that have more than one parse prefixed by #AMBIGUOUS" ++ + "\n options for selecting parsing method:" ++ + "\n -fcfg parse using a fast variant of MCFG (default is no HOAS in grammar)" ++ + "\n -old parse using an overgenerating CFG (default if HOAS in grammar)" ++ + "\n -cfg parse using a much less overgenerating CFG" ++ + "\n -mcfg parse using an even less overgenerating MCFG" ++ + "\n Note: the first time parsing with -cfg, -mcfg, and -fcfg may take a long time" ++ + "\n options that only work for the -old default parsing method:" ++ + "\n -n non-strict: tolerates morphological errors" ++ + "\n -ign ignore unknown words when parsing" ++ + "\n -raw return context-free terms in raw form" ++ + "\n -v verbose: give more information if parsing fails" ++ + "\n flags:" ++ + "\n -cat parse in this category" ++ + "\n -lang parse in this grammar" ++ + "\n -lexer filter input through this lexer" ++ + "\n -parser use this parsing strategy" ++ + "\n -number return this many results at most" ++ + "\n examples:" ++ + "\n p -cat=S -mcfg \"jag \228r gammal\" -- parse an S with the MCFG" ++ + "\n rf examples.txt | p -lines -- parse each non-empty line of the file" ++ + "\n" ++ + "\nat, apply_transfer: at (Module.Fun | Fun)" ++ + "\n Transfer a term using Fun from Module, or the topmost transfer" ++ + "\n module. Transfer modules are given in the .trc format. They are" ++ + "\n shown by the 'po' command." ++ + "\n flags:" ++ + "\n -lang typecheck the result in this lang instead of default lang" ++ + "\n examples:" ++ + "\n p -lang=Cncdecimal \"123\" | at num2bin | l -- convert dec to bin" ++ + "\n" ++ + "\ntb, tree_bank: tb" ++ + "\n Generate a multilingual treebank from a list of trees (default) or compare" ++ + "\n to an existing treebank." ++ + "\n options:" ++ + "\n -c compare to existing xml-formatted treebank" ++ + "\n -trees return the trees of the treebank" ++ + "\n -all show all linearization alternatives (branches and variants)" ++ + "\n -table show tables of linearizations with parameters" ++ + "\n -record show linearization records" ++ + "\n -xml wrap the treebank (or comparison results) with XML tags" ++ + "\n -mem write the treebank in memory instead of a file TODO" ++ + "\n examples:" ++ + "\n gr -cat=S -number=100 | tb -xml | wf tb.xml -- random treebank into file" ++ + "\n rf tb.xml | tb -c -- compare-test treebank from file" ++ + "\n rf old.xml | tb -trees | tb -xml -- create new treebank from old" ++ + "\n" ++ + "\nut, use_treebank: ut String" ++ + "\n Lookup a string in a treebank and return the resulting trees." ++ + "\n Use 'tb' to create a treebank and 'i -treebank' to read one from" ++ + "\n a file." ++ + "\n options:" ++ + "\n -assocs show all string-trees associations in the treebank" ++ + "\n -strings show all strings in the treebank" ++ + "\n -trees show all trees in the treebank" ++ + "\n -raw return the lookup result as string, without typechecking it" ++ + "\n flags:" ++ + "\n -treebank use this treebank (instead of the latest introduced one)" ++ + "\n examples:" ++ + "\n ut \"He adds this to that\" | l -multi -- use treebank lookup as parser in translation" ++ + "\n ut -assocs | grep \"ComplV2\" -- show all associations with ComplV2" ++ + "\n" ++ + "\ntt, test_tokenizer: tt String" ++ + "\n Show the token list sent to the parser when String is parsed." ++ + "\n HINT: can be useful when debugging the parser." ++ + "\n flags: " ++ + "\n -lexer use this lexer" ++ + "\n examples:" ++ + "\n tt -lexer=codelit \"2*(x + 3)\" -- a favourite lexer for program code" ++ + "\n" ++ + "\ng, grep: g String1 String2" ++ + "\n Grep the String1 in the String2. String2 is read line by line," ++ + "\n and only those lines that contain String1 are returned." ++ + "\n flags:" ++ + "\n -v return those lines that do not contain String1." ++ + "\n examples:" ++ + "\n pg -printer=cf | grep \"mother\" -- show cf rules with word mother" ++ + "\n" ++ + "\ncc, compute_concrete: cc Term" ++ + "\n Compute a term by concrete syntax definitions. Uses the topmost" ++ + "\n resource module (the last in listing by command po) to resolve " ++ + "\n constant names. " ++ + "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ + "\n the oper definitions to be retained after compilation; otherwise this" ++ + "\n command does not expand oper constants." ++ + "\n N.B.' The resulting Term is not a term in the sense of abstract syntax," ++ + "\n and hence not a valid input to a Tree-demanding command." ++ + "\n flags:" ++ + "\n -table show output in a similar readable format as 'l -table'" ++ + "\n -res use another module than the topmost one" ++ + "\n examples:" ++ + "\n cc -res=ParadigmsFin (nLukko \"hyppy\") -- inflect \"hyppy\" with nLukko" ++ + "\n" ++ + "\nso, show_operations: so Type" ++ + "\n Show oper operations with the given value type. Uses the topmost " ++ + "\n resource module to resolve constant names. " ++ + "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ + "\n the oper definitions to be retained after compilation; otherwise this" ++ + "\n command does not find any oper constants." ++ + "\n N.B.' The value type may not be defined in a supermodule of the" ++ + "\n topmost resource. In that case, use appropriate qualified name." ++ + "\n flags:" ++ + "\n -res use another module than the topmost one" ++ + "\n examples:" ++ + "\n so -res=ParadigmsFin ResourceFin.N -- show N-paradigms in ParadigmsFin" ++ + "\n" ++ + "\nt, translate: t Lang Lang String" ++ + "\n Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lexer" ++ + "\n -parser" ++ + "\n examples:" ++ + "\n t Eng Swe -cat=S \"every number is even or odd\"" ++ + "\n" ++ + "\ngr, generate_random: gr Tree?" ++ + "\n Generates a random Tree of a given category. If a Tree" ++ + "\n argument is given, the command completes the Tree with values to" ++ + "\n the metavariables in the tree. " ++ + "\n options:" ++ + "\n -prob use probabilities (works for nondep types only)" ++ + "\n -cf use a very fast method (works for nondep types only)" ++ + "\n flags:" ++ + "\n -cat generate in this category" ++ + "\n -lang use the abstract syntax of this grammar" ++ + "\n -number generate this number of trees (not impl. with Tree argument)" ++ + "\n -depth use this number of search steps at most" ++ + "\n examples:" ++ + "\n gr -cat=Query -- generate in category Query" ++ + "\n gr (PredVP ? (NegVG ?)) -- generate a random tree of this form" ++ + "\n gr -cat=S -tr | l -- gererate and linearize" ++ + "\n" ++ + "\ngt, generate_trees: gt Tree?" ++ + "\n Generates all trees up to a given depth. If the depth is large," ++ + "\n a small -alts is recommended. If a Tree argument is given, the" ++ + "\n command completes the Tree with values to the metavariables in" ++ + "\n the tree." ++ + "\n options:" ++ + "\n -metas also return trees that include metavariables" ++ + "\n -all generate all (can be infinitely many, lazily)" ++ + "\n -lin linearize result of -all (otherwise, use pipe to linearize)" ++ + "\n flags:" ++ + "\n -depth generate to this depth (default 3)" ++ + "\n -atoms take this number of atomic rules of each category (default unlimited)" ++ + "\n -alts take this number of alternatives at each branch (default unlimited)" ++ + "\n -cat generate in this category" ++ + "\n -nonub don't remove duplicates (faster, not effective with -mem)" ++ + "\n -mem use a memorizing algorithm (often faster, usually more memory-consuming)" ++ + "\n -lang use the abstract syntax of this grammar" ++ + "\n -number generate (at most) this number of trees (also works with -all)" ++ + "\n -noexpand don't expand these categories (comma-separated, e.g. -noexpand=V,CN)" ++ + "\n -doexpand only expand these categories (comma-separated, e.g. -doexpand=V,CN)" ++ + "\n examples:" ++ + "\n gt -depth=10 -cat=NP -- generate all NP's to depth 10 " ++ + "\n gt (PredVP ? (NegVG ?)) -- generate all trees of this form" ++ + "\n gt -cat=S -tr | l -- generate and linearize" ++ + "\n gt -noexpand=NP | l -mark=metacat -- the only NP is meta, linearized \"?0 +NP\"" ++ + "\n gt | l | p -lines -ambiguous | grep \"#AMBIGUOUS\" -- show ambiguous strings" ++ + "\n" ++ + "\nma, morphologically_analyse: ma String" ++ + "\n Runs morphological analysis on each word in String and displays" ++ + "\n the results line by line." ++ + "\n options:" ++ + "\n -short show analyses in bracketed words, instead of separate lines" ++ + "\n -status show just the work at success, prefixed with \"*\" at failure" ++ + "\n flags:" ++ + "\n -lang" ++ + "\n examples:" ++ + "\n wf Bible.txt | ma -short | wf Bible.tagged -- analyse the Bible" ++ + "\n" ++ + "\n" ++ + "\n-- elementary generation of Strings and Trees" ++ + "\n" ++ + "\nps, put_string: ps String" ++ + "\n Returns its argument String, like Unix echo." ++ + "\n HINT. The strength of ps comes from the possibility to receive the " ++ + "\n argument from a pipeline, and altering it by the -filter flag." ++ + "\n flags:" ++ + "\n -filter filter the result through this string processor " ++ + "\n -length cut the string after this number of characters" ++ + "\n examples:" ++ + "\n gr -cat=Letter | l | ps -filter=text -- random letter as text" ++ + "\n" ++ + "\npt, put_tree: pt Tree" ++ + "\n Returns its argument Tree, like a specialized Unix echo." ++ + "\n HINT. The strength of pt comes from the possibility to receive " ++ + "\n the argument from a pipeline, and altering it by the -transform flag." ++ + "\n flags:" ++ + "\n -transform transform the result by this term processor" ++ + "\n -number generate this number of terms at most" ++ + "\n examples:" ++ + "\n p \"zero is even\" | pt -transform=solve -- solve ?'s in parse result" ++ + "\n" ++ + "\n* st, show_tree: st Tree" ++ + "\n Prints the tree as a string. Unlike pt, this command cannot be" ++ + "\n used in a pipe to produce a tree, since its output is a string." ++ + "\n flags:" ++ + "\n -printer show the tree in a special format (-printer=xml supported)" ++ + "\n" ++ + "\nwt, wrap_tree: wt Fun" ++ + "\n Wraps the tree as the sole argument of Fun." ++ + "\n flags:" ++ + "\n -c compute the resulting new tree to normal form" ++ + "\n" ++ + "\nvt, visualize_tree: vt Tree" ++ + "\n Shows the abstract syntax tree via dot and gv (via temporary files" ++ + "\n grphtmp.dot, grphtmp.ps)." ++ + "\n flags:" ++ + "\n -c show categories only (no functions)" ++ + "\n -f show functions only (no categories)" ++ + "\n -g show as graph (sharing uses of the same function)" ++ + "\n -o just generate the .dot file" ++ + "\n examples:" ++ + "\n p \"hello world\" | vt -o | wf my.dot ;; ! open -a GraphViz my.dot" ++ + "\n -- This writes the parse tree into my.dot and opens the .dot file" ++ + "\n -- with another application without generating .ps." ++ + "\n" ++ + "\n-- subshells" ++ + "\n" ++ + "\nes, editing_session: es" ++ + "\n Opens an interactive editing session." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ + "\n" ++ + "\nts, translation_session: ts" ++ + "\n Translates input lines from any of the actual languages to all other ones." ++ + "\n To exit, type a full stop (.) alone on a line." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Windows)" ++ + "\n -lang prepend translation results with language names" ++ + "\n flags:" ++ + "\n -cat the parser category" ++ + "\n examples:" ++ + "\n ts -cat=Numeral -lang -- translate numerals, show language names" ++ + "\n" ++ + "\ntq, translation_quiz: tq Lang Lang" ++ + "\n Random-generates translation exercises from Lang1 to Lang2," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n examples:" ++ + "\n tq -cat=NP TestResourceEng TestResourceSwe -- quiz for NPs" ++ + "\n" ++ + "\ntl, translation_list: tl Lang Lang" ++ + "\n Random-generates a list of ten translation exercises from Lang1" ++ + "\n to Lang2. The number can be changed by a flag." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -number" ++ + "\n examples:" ++ + "\n tl -cat=NP TestResourceEng TestResourceSwe -- quiz list for NPs" ++ + "\n" ++ + "\nmq, morphology_quiz: mq" ++ + "\n Random-generates morphological exercises," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: use printname judgements in your grammar to" ++ + "\n produce nice expressions for desired forms." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n examples:" ++ + "\n mq -cat=N -lang=TestResourceSwe -- quiz for Swedish nouns" ++ + "\n" ++ + "\nml, morphology_list: ml" ++ + "\n Random-generates a list of ten morphological exercises," ++ + "\n keeping score of success. The number can be changed with a flag." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n -number" ++ + "\n examples:" ++ + "\n ml -cat=N -lang=TestResourceSwe -- quiz list for Swedish nouns" ++ + "\n" ++ + "\n" ++ + "\n-- IO related commands" ++ + "\n" ++ + "\nrf, read_file: rf File" ++ + "\n Returns the contents of File as a String; error if File does not exist." ++ + "\n" ++ + "\nwf, write_file: wf File String" ++ + "\n Writes String into File; File is created if it does not exist." ++ + "\n N.B. the command overwrites File without a warning." ++ + "\n" ++ + "\naf, append_file: af File" ++ + "\n Writes String into the end of File; File is created if it does not exist." ++ + "\n" ++ + "\n* tg, transform_grammar: tg File" ++ + "\n Reads File, parses as a grammar, " ++ + "\n but instead of compiling further, prints it. " ++ + "\n The environment is not changed. When parsing the grammar, the same file" ++ + "\n name suffixes are supported as in the i command." ++ + "\n HINT: use this command to print the grammar in " ++ + "\n another format (the -printer flag); pipe it to wf to save this format." ++ + "\n flags:" ++ + "\n -printer (only -printer=latex supported currently)" ++ + "\n" ++ + "\n* cl, convert_latex: cl File" ++ + "\n Reads File, which is expected to be in LaTeX form." ++ + "\n Three environments are treated in special ways:" ++ + "\n \\begGF - \\end{verbatim}, which contains GF judgements," ++ + "\n \\begTGF - \\end{verbatim}, which contains a GF expression (displayed)" ++ + "\n \\begInTGF - \\end{verbatim}, which contains a GF expressions (inlined)." ++ + "\n Moreover, certain macros should be included in the file; you can" ++ + "\n get those macros by applying 'tg -printer=latex foo.gf' to any grammar" ++ + "\n foo.gf. Notice that the same File can be imported as a GF grammar," ++ + "\n consisting of all the judgements in \\begGF environments." ++ + "\n HINT: pipe with 'wf Foo.tex' to generate a new Latex file." ++ + "\n" ++ + "\nsa, speak_aloud: sa String" ++ + "\n Uses the Flite speech generator to produce speech for String." ++ + "\n Works for American English spelling. " ++ + "\n examples:" ++ + "\n h | sa -- listen to the list of commands" ++ + "\n gr -cat=S | l | sa -- generate a random sentence and speak it aloud" ++ + "\n" ++ + "\nsi, speech_input: si" ++ + "\n Uses an ATK speech recognizer to get speech input. " ++ + "\n flags:" ++ + "\n -lang: The grammar to use with the speech recognizer." ++ + "\n -cat: The grammar category to get input in." ++ + "\n -language: Use acoustic model and dictionary for this language." ++ + "\n -number: The number of utterances to recognize." ++ + "\n" ++ + "\nh, help: h Command?" ++ + "\n Displays the paragraph concerning the command from this help file." ++ + "\n Without the argument, shows the first lines of all paragraphs." ++ + "\n options" ++ + "\n -all show the whole help file" ++ + "\n -defs show user-defined commands and terms" ++ + "\n -FLAG show the values of FLAG (works for grammar-independent flags)" ++ + "\n examples:" ++ + "\n h print_grammar -- show all information on the pg command" ++ + "\n" ++ + "\nq, quit: q" ++ + "\n Exits GF." ++ + "\n HINT: you can use 'ph | wf history' to save your session." ++ + "\n" ++ + "\n!, system_command: ! String" ++ + "\n Issues a system command. No value is returned to GF." ++ + "\n example:" ++ + "\n ! ls" ++ + "\n" ++ + "\n?, system_command: ? String" ++ + "\n Issues a system command that receives its arguments from GF pipe" ++ + "\n and returns a value to GF." ++ + "\n example:" ++ + "\n h | ? 'wc -l' | p -cat=Num" ++ + "\n" ++ + "\n" ++ + "\n-- Flags. The availability of flags is defined separately for each command." ++ + "\n" ++ + "\n-cat, category in which parsing is performed." ++ + "\n The default is S." ++ + "\n" ++ + "\n-depth, the search depth in e.g. random generation." ++ + "\n The default depends on application." ++ + "\n" ++ + "\n-filter, operation performed on a string. The default is identity." ++ + "\n -filter=identity no change" ++ + "\n -filter=erase erase the text" ++ + "\n -filter=take100 show the first 100 characters" ++ + "\n -filter=length show the length of the string" ++ + "\n -filter=text format as text (punctuation, capitalization)" ++ + "\n -filter=code format as code (spacing, indentation)" ++ + "\n" ++ + "\n-lang, grammar used when executing a grammar-dependent command." ++ + "\n The default is the last-imported grammar." ++ + "\n" ++ + "\n-language, voice used by Festival as its --language flag in the sa command. " ++ + "\n The default is system-dependent. " ++ + "\n" ++ + "\n-length, the maximum number of characters shown of a string. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-lexer, tokenization transforming a string into lexical units for a parser." ++ + "\n The default is words." ++ + "\n -lexer=words tokens are separated by spaces or newlines" ++ + "\n -lexer=literals like words, but GF integer and string literals recognized" ++ + "\n -lexer=vars like words, but \"x\",\"x_...\",\"$...$\" as vars, \"?...\" as meta" ++ + "\n -lexer=chars each character is a token" ++ + "\n -lexer=code use Haskell's lex" ++ + "\n -lexer=codevars like code, but treat unknown words as variables, ?? as meta " ++ + "\n -lexer=textvars like text, but treat unknown words as variables, ?? as meta " ++ + "\n -lexer=text with conventions on punctuation and capital letters" ++ + "\n -lexer=codelit like code, but treat unknown words as string literals" ++ + "\n -lexer=textlit like text, but treat unknown words as string literals" ++ + "\n -lexer=codeC use a C-like lexer" ++ + "\n -lexer=ignore like literals, but ignore unknown words" ++ + "\n -lexer=subseqs like ignore, but then try all subsequences from longest" ++ + "\n" ++ + "\n-number, the maximum number of generated items in a list. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-optimize, optimization on generated code." ++ + "\n The default is share for concrete, none for resource modules." ++ + "\n Each of the flags can have the suffix _subs, which performs" ++ + "\n common subexpression elimination after the main optimization." ++ + "\n Thus, -optimize=all_subs is the most aggressive one. The _subs" ++ + "\n strategy only works in GFC, and applies therefore in concrete but" ++ + "\n not in resource modules." ++ + "\n -optimize=share share common branches in tables" ++ + "\n -optimize=parametrize first try parametrize then do share with the rest" ++ + "\n -optimize=values represent tables as courses-of-values" ++ + "\n -optimize=all first try parametrize then do values with the rest" ++ + "\n -optimize=none no optimization" ++ + "\n" ++ + "\n-parser, parsing strategy. The default is chart. If -cfg or -mcfg are" ++ + "\n selected, only bottomup and topdown are recognized." ++ + "\n -parser=chart bottom-up chart parsing" ++ + "\n -parser=bottomup a more up to date bottom-up strategy" ++ + "\n -parser=topdown top-down strategy" ++ + "\n -parser=old an old bottom-up chart parser" ++ + "\n" ++ + "\n-printer, format in which the grammar is printed. The default is" ++ + "\n gfc. Those marked with M are (only) available for pm, the rest" ++ + "\n for pg." ++ + "\n -printer=gfc GFC grammar" ++ + "\n -printer=gf GF grammar" ++ + "\n -printer=old old GF grammar" ++ + "\n -printer=cf context-free grammar, with profiles" ++ + "\n -printer=bnf context-free grammar, without profiles" ++ + "\n -printer=lbnf labelled context-free grammar for BNF Converter" ++ + "\n -printer=plbnf grammar for BNF Converter, with precedence levels" ++ + "\n *-printer=happy source file for Happy parser generator (use lbnf!)" ++ + "\n -printer=haskell abstract syntax in Haskell, with transl to/from GF" ++ + "\n -printer=haskell_gadt abstract syntax GADT in Haskell, with transl to/from GF" ++ + "\n -printer=morpho full-form lexicon, long format" ++ + "\n *-printer=latex LaTeX file (for the tg command)" ++ + "\n -printer=fullform full-form lexicon, short format" ++ + "\n *-printer=xml XML: DTD for the pg command, object for st" ++ + "\n -printer=old old GF: file readable by GF 1.2" ++ + "\n -printer=stat show some statistics of generated GFC" ++ + "\n -printer=probs show probabilities of all functions" ++ + "\n -printer=gsl Nuance GSL speech recognition grammar" ++ + "\n -printer=jsgf Java Speech Grammar Format" ++ + "\n -printer=jsgf_sisr_old Java Speech Grammar Format with semantic tags in " ++ + "\n SISR WD 20030401 format" ++ + "\n -printer=srgs_abnf SRGS ABNF format" ++ + "\n -printer=srgs_abnf_non_rec SRGS ABNF format, without any recursion." ++ + "\n -printer=srgs_abnf_sisr_old SRGS ABNF format, with semantic tags in" ++ + "\n SISR WD 20030401 format" ++ + "\n -printer=srgs_xml SRGS XML format" ++ + "\n -printer=srgs_xml_non_rec SRGS XML format, without any recursion." ++ + "\n -printer=srgs_xml_prob SRGS XML format, with weights" ++ + "\n -printer=srgs_xml_sisr_old SRGS XML format, with semantic tags in" ++ + "\n SISR WD 20030401 format" ++ + "\n -printer=vxml Generate a dialogue system in VoiceXML." ++ + "\n -printer=slf a finite automaton in the HTK SLF format" ++ + "\n -printer=slf_graphviz the same automaton as slf, but in Graphviz format" ++ + "\n -printer=slf_sub a finite automaton with sub-automata in the " ++ + "\n HTK SLF format" ++ + "\n -printer=slf_sub_graphviz the same automaton as slf_sub, but in " ++ + "\n Graphviz format" ++ + "\n -printer=fa_graphviz a finite automaton with labelled edges" ++ + "\n -printer=regular a regular grammar in a simple BNF" ++ + "\n -printer=unpar a gfc grammar with parameters eliminated" ++ + "\n -printer=functiongraph abstract syntax functions in 'dot' format" ++ + "\n -printer=typegraph abstract syntax categories in 'dot' format" ++ + "\n -printer=transfer Transfer language datatype (.tr file format)" ++ + "\n -printer=cfg-prolog M cfg in prolog format (also pg)" ++ + "\n -printer=gfc-prolog M gfc in prolog format (also pg)" ++ + "\n -printer=gfcm M gfcm file (default for pm)" ++ + "\n -printer=graph M module dependency graph in 'dot' (graphviz) format" ++ + "\n -printer=header M gfcm file with header (for GF embedded in Java)" ++ + "\n -printer=js M JavaScript type annotator and linearizer" ++ + "\n -printer=mcfg-prolog M mcfg in prolog format (also pg)" ++ + "\n -printer=missing M the missing linearizations of each concrete" ++ + "\n" ++ + "\n-startcat, like -cat, but used in grammars (to avoid clash with keyword cat)" ++ + "\n" ++ + "\n-transform, transformation performed on a syntax tree. The default is identity." ++ + "\n -transform=identity no change" ++ + "\n -transform=compute compute by using definitions in the grammar" ++ + "\n -transform=nodup return the term only if it has no constants duplicated" ++ + "\n -transform=nodupatom return the term only if it has no atomic constants duplicated" ++ + "\n -transform=typecheck return the term only if it is type-correct" ++ + "\n -transform=solve solve metavariables as derived refinements" ++ + "\n -transform=context solve metavariables by unique refinements as variables" ++ + "\n -transform=delete replace the term by metavariable" ++ + "\n" ++ + "\n-unlexer, untokenization transforming linearization output into a string." ++ + "\n The default is unwords." ++ + "\n -unlexer=unwords space-separated token list (like unwords)" ++ + "\n -unlexer=text format as text: punctuation, capitals, paragraph

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

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